perm filename MSOLD[FOO,MUS] blob
sn#007299 filedate 1972-11-04 generic text, type T, neo UTF8
********** MUMSS: DISPLAYS MUSIC AND DRAWS IT ON THE PLOTTER **********
TO RUN: 'DO MUMSS' - OR -
LOAD MSS,NOTWRT,ITMSUB,HOMER,PLTSRT,SC2,KSIG,SCRHY,SCNOTES,BEAMS,MSSCAN
******* KEY TO THE PARAMETER NUMBERS *******
1 NOTES: 1, POS, STF, NT #, (P5) STEM DIR & ACCI, (P6) FILLED IN? (≥0)
(P7)TAIL RH.(0,1,2,3,4=64),(P8)STEM EXT. BY NT#,(P9)=1 TO SPPRSS LED.LNS
FOR P6:-2,2 'HOMES' TO LEFT, -3,3 'HOMES' TO RIGHT.(FOR CHORDS, ETC.)
FOR P5: >10= NO STEM, 10-14=STEM UP, 20-24= STEM DOWN;P1 100S GIVE MINIS
IF P7 HAS 2 DIGITS THE NOTE IS DOTTED; 2ND DIG. IS # OF TAILS.
DECIMALS AFTER P5 OR P7 SPACE OUT ACCIDENTAL OR DOT.
2 CLEFS: 2, POS, STAFF, CLEF(TREB=1, BASS=2, ALTO=3, TENOR=4)
3 RESTS: 3,POS,STF,HGT,REST(-2=WHOLE, 0=1/4, 1=1/8, ETC),P6) 1=DOTTED
4 LINES: 4,POS,LOWEST STF, NUM OF STAVES.(IF BAR) OR NT1, NT2, POS2, 1=DASHES.
P7=-1 GIVES VERTICAL WAVEY LINE, P7=4 GIVES HEAVY LINES
5 NUMBERS: 5, POS, STF, NT #, SIZE(100'S), NUM
6 ACCIDS, DOT, ACCENT: 6,POS,STF,NOTE #, P5
FOR P5: DOT=0,b=1,#=2,NAT=3,ACC ∧=4(-4=INV),ACC >=5,FERMATA=6(-6=INV),
REPEAT BAR SIGN=8, DASH=9. SET P6 TO 1 FOR AUTOMATIC HOMING.
7 LEDGER LINES: 7,POS,STF,# UP OR DOWN(+,-) (IS THIS USEFUL??)
8 SLURS: 8, POS1, STAFF, NT1, NT2, POS2, DIT ACCIDENTAL OR DOT.
2 CLEFS: 2, POS, STAFF, CLEF(TREB=1, BASS=2, ALTO=3, TENOR=4)
3 RESTS: 3,POS,STF,HGT,REST(-2=WHOLE, 0=1/4, 1=1/8, ETC),P6) 1=DOTTED
4 LINES: 4,POS,LOWEST STF, NUM OF STAVES.(IF BAR) OR NT1, NT2, POS2, 1=DASHES.
P7=-1 GIVES VERTICAL WAVEY LINE, P7=4 GIVES HEAVY LINES
5 NUMBERS: 5, POS, STF, NT #, SIZE(100'S), NUM
6 ACCIDS, DOT, ACCENT: 6,POS,STF,NOTE #, P5
FOR P5: DOT=0,b=1,#=2,NAT=3,ACC ∧=4(-4=INV),ACC >=5,FERMATA=6(-6=INV),
REPEAT BAR SIGN=8, DASH=9. SET P6 TO 1 FOR AUTOMATIC HOMING.
7 LEDGER LINES: 7,POS,STF,# UP OR DOWN(+,-) (IS THIS USEFUL??)
8 SLURS: 8, POS1, STAFF, NT1, NT2, POS2, DIP(NT UNITS + OR -), P8
FOR P8 0=SLUR, 1=BRACKET, 2=LFT 1/2 BRKT, 3=RT 1/2 BRKT.
9 BEAMS: 9,POS, STF, NT1, NT2, POS2, 7)STEM DIR(10=↑ 20=↓), 8)RT-LFT?,9)POS3.
P10)=# OF BEAMS DISPLACED. (2ND DIG. IN P7=TOTAL # OF BEAMS.)
-- FOR P8: 10=LFT, 20=RT
10 FOR STAFF LINES: 10,POS1, HGT(3 TO -3), 2ND POS., DISPLACEMENT(BY NOTE #)
101 SPACING SCALE: 101, ABOVE WHICH STAFF(101,99 ERASES IT)
11 USER SUBROUTINE: 11, POS, STAFF, NOTE#, P5-P12 AVAILABLE.(SEE BOTTOM FOR EXAMPLE)
12 GET OLD DISPLAY: 12,(0,1 TO ADD OLD FILE TO PRESENT DISPLAY)
13 " " " AND PLOT IT: 13, WIDTH FAC., HEIGHT FAC.(BY 100'S), P4, P5, P6
P4=1, PLOTS ONLY THIN LINES. P4=2, PLOTS ALL BUT THIN LINES.
IF P5.NE.0 NO MOVE AT START, IF P6.NE.0 NO MOVE AT END.
SAVE ALL: 1000 (1000,1 SAVES DISPLAY ONLY FOR DPY.F4)
18 METER: 18, POS, STF, TOP #, BOTT # (CREATES SEPARATE ITEM FOR EACH NUM.)
19 ADJUST STEMS TO MEET BEAMS: 19 (ALSO REMOVES TAILS WHERE NEEDED)
20 TRILLS: 20, POS1, STF, NOTE#, POS2
30 TREMOLO: 30, POS, STF, NT#, STEM DIR(10↑,20↓), # OF BEAMS.
****** VARIOUS WAYS TO GET INTO EDIT MODE ********
22, ITEM (222 TO LEAVE EDIT MODE)(2222 SAVES OLD AND NEW FORMS)
33, POS, STAFF, CODE#(AFTER THIS OTHER EDIT COMMANDS ARE SAME)
44, STAFF -- EDITS ONLY ITEMS ON THAT STAFF
55,POS -- EDITS ONLY ITEMS + OR - 5 STEPS FROM POS. TYPE 55 TO ALIGN ITEMS.
IN EDIT MODE: 0,N (MOVES N SPACES)
PN1,N1 PN2,N2 PN3,N3 ETC.(TYPE PAIRS OF NUMS. TO CHNG PARAMS)
0,0 (ENDS EDIT AND MOVES TO NEXT ITEM FOR EDIT)
222 (ENDS EDIT, RETURNS TO INPUT MODE)
2222(SAVES OLD AND NEW FORMS)--2222,N SAVES & MOVES TO ITEM N.
99 (DELETES ITEM AND MOVES ON TO NEXT)
MOVE SIDEWAYS: 23, LF POS, RT POS, STF(>10=ALL), MOVE DIS OR NEW LF, NEW RT,
P7=NEW STF #(10=0), P8 1=LEAVE OLD BEHIND
MOVE UP-DN: 25, POS1, POS2, STF, UPT COMMANDS ARE SAME)
44, STAFF -- EDITS ONLY ITEMS ON THAT STAFF
55,POS -- EDITS ONLY ITEMS + OR - 5 STEPS FROM POS. TYPE 55 TO ALIGN ITEMS.
IN EDIT MODE: 0,N (MOVES N SPACES)
PN1,N1 PN2,N2 PN3,N3 ETC.(TYPE PAIRS OF NUMS. TO CHNG PARAMS)
0,0 (ENDS EDIT AND MOVES TO NEXT ITEM FOR EDIT)
222 (ENDS EDIT, RETURNS TO INPUT MODE)
2222(SAVES OLD AND NEW FORMS)--2222,N SAVES & MOVES TO ITEM N.
99 (DELETES ITEM AND MOVES ON TO NEXT)
MOVE SIDEWAYS: 23, LF POS, RT POS, STF(>10=ALL), MOVE DIS OR NEW LF, NEW RT,
P7=NEW STF #(10=0), P8 1=LEAVE OLD BEHIND
MOVE UP-DN: 25, POS1, POS2, STF, UP-DN #
CHANGE N ITEMS: 26,# OF ITEMS,+ LFT-RT,+ UP-DOWN,STAFF#(10=0),1ST ITEM
IF P6=0(1ST ITEM) THEN LAST N ITEMS WILL BE CHANGED.
DELETE: 99 (99 0 N WILL DELETE ALL OF STAFF N. USE 10 FOR STAFF 0)
'SCORE' ITEMS: NOTES-- 14, 0, STAFF
KEY SIG-- 15, POS, STAFF, CLEF(0=TREB, 1=BASS, 2=ALTO, 3=TEN)
LETTERS-- 16, 0, STAFF
TO MOVE LAST ITEM LFT-RT: 0, NUM OF STEPS TO LFT-RT (NOTHING ELSE REQUIRED)
**** HOW TO USE "SCORE" ITEMS ****
NOTES ARE TYPED IN ALMOST EXACTLY AS IN THE "SCORE" PROGRAM.
I.E. S=#, F=b, N=NATURAL (bb AND ## ARE NOT AVAILABLE YET.)
OCTAVE NUMBERS MUST BE USED. 'P' (FOR PROXIMITY MODE) MAY BE USED.
TREBLE CLEF IS ASSUMED. TO CHANGE CLEF, TYPE CLEF NAME FOLLOWED BY A
SLASH. NO MORE THAN 50 NOTE, DOTS AND BEAMS MAY BE
ENTERED AT ONCE. NO MORE THAN 72 CHARACTERS MAY APPEAR ON ONE LINE OF
INPUT. (MORE THAN ONE LINE MAY BE USED.)
THE LINE MUST END WITH A SEMICOLON OR, IF NO MORE NOTES ARE TO
APPEAR, WITH '*'.
THE MOTIVIC FEATURES OF "SCORE" MAY BE USED. MOTIVES ARE SAVED
WITH DISPLAY DATA. (NO MORE THAN 200 ITEMS CAN BE SAVED IN ANY
LIST OF MOTIVES.) CHORDS ARE CONSTRUCTED BY USING THE COLON WITH
NOTES. THE COLON CAUSES THE NOTE TO OCCUPY THE SAME RHYTHMIC POSITION
AS MODE) MAY BE USED.
TREBLE CLEF IS ASSUMED. TO CHANGE CLEF, TYPE CLEF NAME FOLLOWED BY A
SLASH. NO MORE THAN 50 NOTE, DOTS AND BEAMS MAY BE
ENTERED AT ONCE. NO MORE THAN 72 CHARACTERS MAY APPEAR ON ONE LINE OF
INPUT. (MORE THAN ONE LINE MAY BE USED.)
THE LINE MUST END WITH A SEMICOLON OR, IF NO MORE NOTES ARE TO
APPEAR, WITH '*'.
THE MOTIVIC FEATURES OF "SCORE" MAY BE USED. MOTIVES ARE SAVED
WITH DISPLAY DATA. (NO MORE THAN 200 ITEMS CAN BE SAVED IN ANY
LIST OF MOTIVES.) CHORDS ARE CONSTRUCTED BY USING THE COLON WITH
NOTES. THE COLON CAUSES THE NOTE TO OCCUPY THE SAME RHYTHMIC POSITION
AS THE LAST NOTE TO APPEAR WITHOUT A COLON. THE STEM DIRECTION IN
CHORDS WILL BE DETERMINED BY THE ORDER OF APPEARANCE OF THE NOTES.
IF THE FIRST NOTE IS THE LOWEST, THE STEM GOES UP; IF THE FIRST IS THE
HIGHEST, THE STEM GOES DOWN.
EX. BASS/C3/EF/E/D X 3/EN2/GS:/B:*
THE 3RD NOTE WILL BE AN 'E' WITH NO ACCIDENTAL.
THE LAST 3 NOTES WILL BE AN E MAJOR CHORD.
AFTER THE LAST NOTE HAS BEEN ENTERED THE PROGRAM WILL
ASK FOR 'POS1, POS2'.
THE NOTES WILL BE EVENLY SPACED BETWEEN THE 2 POSITIONS ENTERED.
(<CR>=10,200) NEXT YOU WILL BE ASKED TO 'TYPE RHYTHM'.
FOLLOW THE SAME RULES AS IN "SCORE". THE SIMPLER DOTTED RHYTHMS
WILL AUTOMATICALLY PUT DOTS ON NOTES. MORE COMPLEX RHYTHMS MUST
BE DOTTED INDIVIDUALLY. (THEY WILL BE CORRECTLY SPACED.)
NEXT YOU WILL BE ASKED 'ADD BEAMS?' TYPE 'Y' OR 'N'. TO THIS.
IF BEAMS ARE ADDED, DATA MUST BE ENTERED FOR EACH RHYTHMIC VALUE
PREVIOUSLY GIVEN. BEAMS ARE INDICATED BY 2-DIGIT NUMBERS. IF THE
FIRST DIGIT IS 1, THE STEMS WILL GO UP; IF IT IS 2, THEY WILL GO DOWN.
THE 2ND DIGIT MUST BE THE NUMBER OF BEAMS DESIRED. TYPE '99' TO SHOW
THE END POINT OF THE BEAMS. ANY NOTE NOT USING BEAMS SHOULD HAVE A
'0'.
IF YOU HAVE 4 16TH NOTES (STEMS UP) FOLLOWED BY 2 QUARTERS
AND 2 8THS (STEMS DOWN) TYPE:
12///99/0//21/99*
ALL PARTIAL BEAMS MUST BE ADDED INDIVIDUALLY AS YET.
LASTLY YOU WILL BE ASKED 'ADD SLURS?' TYPE 'Y' OR 'N'. TO THIS.
IF SLURS ARE ADDED, DATA MUST BE ENTERED FOR EACH RHYTHMIC VALUE
PREVIOUSLY GIVEN. SLURS ARE INDICATED BY POSITIVE OR NEGATIVE NUMBERS.
A POSITIVE NUMBER WILL PUT THE SLUR ABOVE THE NOTES; NEGATIVE, BELOW.
THE AMOUNT OF CURVE WILL DEPEND ON THE SIZE OF THE NUMBER.
TYPE '99' TO SHOW THE END POINT OF THE SLURS.
ANY NOTE NOT USING SLURS SHOULD HAVE A '0'.
(THERE IS NO PROVISION AS YET FOR HAVING THE END OF A SLUR AND THE
BEGINNING OF THE NEXT OCCUR ON THE SAME NOTE. THIS CAN BE DONE
NON-AUTOMATICALLY HOWEVER.)
A TYPICAL EXAMPLE OF INPUT: 2///99/0//-3 X 7/99*
ALL ITEMS ENTERED UNDER '14' MAY BE EDITED LATER AS IF THEY
WERE ENTERED INDIVIDUALLY.
***** FOLLOWING IS A TYPICAL USER-ADDED SUBROUTINE. *****
SUBROUTINE MSSUB(X,Y,R)
DIMENSION R(20)
C THE UPPER TWO LINES ARE OBLIGATORY.
C NEXT IS LINE DRAWING CALL. L=2, LINE; L=3, JUMPS.
C CALL LINES(A,B,L) [WHERE A AND B ARE THE X AND Y COORDITNATES.]
C R(1) AND R(2) [I.E. P3 AND P4] ARE ALWAYS STAFF # AND NOTE # AT ORIGIN.
C IF NOTE #S ARE USED FOR UP-DOWN, MULTIPLY NOTE# BY 7.
C IF LEFT-RIGHT POSITION #S ARE USED MULTIPLY BY 5.96
C IT IS BEST TO DO EVERYTHING IN TERMS OF 'RELATIVE' VECTORS, AS FOLLOWS.
CALL LINES(R(3)*5.96+X,R(4)*5.96+Y,2)
CALL LINES(R(5)*5.96+X,R(6)*5.96+Y,2)
CALL LINES(R(5)*5.96+X,R(8)*5.96+Y,2)
CALL LINES(R(9)*5.96+X,R(10)*5.96+Y,2)
END
RETURN
C DRAWS QUADRILATERAL. INPUT FOR A SQUARE: 11 50 0 4 5,0 5,5 0,5 0,0
C USE NO MORE THAN 12 PARAMETERS TOTAL!!!
********* TO SET UP AUTOMATIC IRREGULAR RHYTHMIC SPACING *******
ANY NOTES WHICH APPEAR ON STAFF 4 WILL CAUSE ALL ITEMS LATER
ENTERED WITH '14' TO BE SPACED ACCORDING TO THE SPACING GIVEN ON STAFF 4.
FOR STAFF 4 DO NOT USE ANY RESTS. SINGLY DOTTED NOTES MAY BE USED BUT
ONLY DUPLE DIVISIONS ARE TO BE USED. (I.E. NO TRIPLETS, ETC.)
AFTER ALL OTHER NOTES ARE PLACED TO SATISFACTION ERASE
ALL OF STAFF 4 BY TYPING '99 0 4'.
IN ORDER TO LEAVE SPACE FOR BAR LINES, ETC. END EACH SPACE SECTION WITH
SOME NOTE VALUE LESS THAN OR EQUAL TO THE SMALLEST VALUE IN YOUR MUSIC.
IN GENERAL IT IS PROBABLY BETTER TO USE MANY SMALL VALUES ON STAFF 4.
THIS WAY IT IS EASIER TO MAKE MANY DELICATE ADJUSTMENTS.
C ********** DISPLAYS MUSIC AND DRAWS IT ON THE PLOTTER **********
C USES SUBR'S:NOTWRT,ITMSUB,HOMER,PLTSRT,SC1,SCRHY,SCNOTE,KSIG,MSSCAN
IMPLICIT INTEGER(A-Q,S-Z)
REAL DIS,PWDS,DISX,A,B,STF,CENTR,POS
DIMENSION RPOS(2,40)
C NEXT LINE ADDED 2 APR.72 PER LCS LETTER.
COMMON/SIZ/RSZ,JCEN,KCEN
COMMON/SCM/V(78),LIST(200),ISCR,LCNT,RSTF,R(8,50)
COMMON /XRN/RN(4000)
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,ST(2800)
1,RJB,HGT,JJB,POS,JA,CENTR,J,JB,JY,K,RJQ(20),X,Y,L,CNT,DISX,JX
1,JQ(20),WDS(200),IX,MEDIT,RJJ(20),STF(8)
EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJE,RJQ(3))
1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
1,(JK,JQ(9)),(JF,JQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2)),(RJC,RJQ(1))
1 ,(TOP,MSUB,HOMER,PLTSRT,SC1,SCRHY,SCNOTE,KSIG,MSSCAN
IMPLICIT INTEGER(A-Q,S-Z)
REAL DIS,PWDS,DISX,A,B,STF,CENTR,POS
DIMENSION RPOS(2,40)
C NEXT LINE ADDED 2 APR.72 PER LCS LETTER.
COMMON/SIZ/RSZ,JCEN,KCEN
COMMON/SCM/V(78),LIST(200),ISCR,LCNT,RSTF,R(8,50)
COMMON /XRN/RN(4000)
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,ST(2800)
1,RJB,HGT,JJB,POS,JA,CENTR,J,JB,JY,K,RJQ(20),X,Y,L,CNT,DISX,JX
1,JQ(20),WDS(200),IX,MEDIT,RJJ(20),STF(8)
EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJE,RJQ(3))
1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
1,(JK,JQ(9)),(JF,JQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2)),(RJC,RJQ(1))
1 ,(TOP,ST(2799)),(BOT,ST(2800)),(RJH,RJQ(6)),(RJI,RJQ(7))
1,(RPOS(1,1),RN(3921))
DATA STF/-369.0,-246.0,-123.0,0.0,123.0,246.0,369.0,450.0/
C ***** TO ADD ---- SAVE 'STF' ARRAY
CALL DPYSET(1,ST,2800)
CALL TYPLOC(-200,-511)
CALL DPYBRT(5)
RPOS(1,1)=0
PLOTIT=0
RSZ=.8571
C LINE ABOVE ADDED 2 APR.72 PER LCS LETTER "BASIC SIZE FACTOR"
TOP=0
BOT=0
X22=0
PLT=0
PWDS(1)=1.
EDX=-1
SCORE=-1
SAVER=5
REDIT=999.
M=1
GO=-1
ITEM=0
ITX=-1
ZERO=-1
WDS(1)=ST(2)
I=1
ISC=0
1000 READX=0
KNT=0
IF(SCORE.OR.R(8,50))GO TO 55
CALL SCMSS
IF(R(8,50))GO TO 55
I=ISC
ITEM=ISITEM
ST(2)=WDS(ITEM+1)
CALL ACCPOG(1)
GO TO 553
57 IF(PLT)GO TO 6120
IF(M.LE.I.AND.GO)CALL DPYOUT(1)
IF(JA.EQ.101)GO TO 5531
ITEM=ITEM+1
K=ST(2)
IF(X22.NE.0)CALL BOX(RJJB,RBOX)
ST(2)=K
IF(K.LT.2800)GO TO 20000
C FOR BUFFER OVERFLOW!
TYPE 1,K
ST(2)=SVST
I=SVI
ITEM=SVITM
CALL ACCPOG(1)
GO TO 5500
20000 WDS(ITEM+1)=K
IF(EDX.NE.-1.AND.M.LT.I)GO TO 6120
PWDS(ITEM+1)=I
CC IF(PLT.EQ.1)TYPE 89,BOT,TOP
PLT=0
IF(GO)GO TO 5531
CALL DPYOUT(1)
GO=-1
5531 IF(READX.EQ.-2)GO TO 653
IF(READX.OR.SCORE.EQ.0)GO TO 553
55 SVST=ST(2)
SVI=I
SVITM=ITEM
K=ITEM+1
IF(X22.EQ.0)GO TO 5503
K=X22
TYPE 427,(RN(L),L=MEDIT+1,MEDIT+3)
IF(YED.LT.2)GO TO 5500
5502 DO 5501 L=4,YED+2
5501 TYPE 4271,L,RN(MEDIT+L)
GO TO 5500
5503 CALL HYDPOG(3)
C TO DELETE VERTICAL LINE (55)
KED=0
5500 IF(READX)GO TO 653
TYPE 56,NAME,K,SVST
JAB=JA
SCORE=-1
ACCEPT 1,JA,RJB,RJQ
IF(JA.EQ.101)GO TO 11
IF(JA.EQ.333)GO TO 6333
C TEMPORARY, TO PRINT RN ARRAY.
IF(JA.EQ.1000)GO TO 1
C TYPE 1000 TO SAVE BUFFER. 1000, 1 -- SAVES ONLY DISPLAY BUFFER.
IF(JA.GT.0)SAVER=SAVER-1
IF(SAVER)GO TO 101
C SAVES EVERY 5TH TIME AROUND
GO TO 553
88 SCORE=0
ISC=I
ISITEM=ITEM
IF(RJC.EQ.4.)RPOS(1,1)=0
IF(JA.EQ.14.AND.RJC.NE.4.)CALL SETUP
C SETUEDIT+1,MEDIT+3)
IF(YED.LT.2)GO TO 5500
5502 DO 5501 L=4,YED+2
5501 TYPE 4271,L,RN(MEDIT+L)
GO TO 5500
5503 CALL HYDPOG(3)
C TO DELETE VERTICAL LINE (55)
KED=0
5500 IF(READX)GO TO 653
TYPE 56,NAME,K,SVST
JAB=JA
SCORE=-1
ACCEPT 1,JA,RJB,RJQ
IF(JA.EQ.101)GO TO 11
IF(JA.EQ.333)GO TO 6333
C TEMPORARY, TO PRINT RN ARRAY.
IF(JA.EQ.1000)GO TO 1
C TYPE 1000 TO SAVE BUFFER. 1000, 1 -- SAVES ONLY DISPLAY BUFFER.
IF(JA.GT.0)SAVER=SAVER-1
IF(SAVER)GO TO 101
C SAVES EVERY 5TH TIME AROUND
GO TO 553
88 SCORE=0
ISC=I
ISITEM=ITEM
IF(RJC.EQ.4.)RPOS(1,1)=0
IF(JA.EQ.14.AND.RJC.NE.4.)CALL SETUP
C SETUP SETS SPACING SCALE FOR "SCORE" ITEMS
DO 9532 K=1,8
DO 9532 L=1,50
9532 R(K,L)=0
RSTF=RJC
R(1,1)=JA
R(2,1)=RJB
R(3,1)=RJD
C MODE, LOCATION, (CLEF)
9533 CALL SCMSS
READX=-1.
IF(R(8,50))GO TO 653
553 IF(SCORE)GO TO 6531
653 KNT=KNT+1
JA=R(1,KNT)
IF(JA.EQ.0)GO TO 653
RJB=R(2,KNT)
DO 7531 K=1,6
7531 RJQ(K)=R(K+2,KNT)
6531 M=1
EDX=-1
IF(JA.EQ.222)GO TO 72
IF(JA.EQ.2222)GO TO 73
IF(JA.EQ.100)GO TO 1000
C 100 STOPS READER.
DO 5532 K=1,20
5532 JQ(K)=RJQ(K)
IF(JA.EQ.99)GO TO 7542
CC IF(JA.LE.0.OR.X22.NE.0)GO TO 5511
IF(JA.EQ.0.OR.X22.NE.0)GO TO 5511
IF(JA.LT.0)GO TO 55
C GOES BACK IP SETS SPACING SCALE FOR "SCORE" ITEMS
DO 9532 K=1,8
DO 9532 L=1,50
9532 R(K,L)=0
RSTF=RJC
R(1,1)=JA
R(2,1)=RJB
R(3,1)=RJD
C MODE, LOCATION, (CLEF)
9533 CALL SCMSS
READX=-1.
IF(R(8,50))GO TO 653
553 IF(SCORE)GO TO 6531
653 KNT=KNT+1
JA=R(1,KNT)
IF(JA.EQ.0)GO TO 653
RJB=R(2,KNT)
DO 7531 K=1,6
7531 RJQ(K)=R(K+2,KNT)
6531 M=1
EDX=-1
IF(JA.EQ.222)GO TO 72
IF(JA.EQ.2222)GO TO 73
IF(JA.EQ.100)GO TO 1000
C 100 STOPS READER.
DO 5532 K=1,20
5532 JQ(K)=RJQ(K)
IF(JA.EQ.99)GO TO 7542
CC IF(JA.LE.0.OR.X22.NE.0)GO TO 5511
IF(JA.EQ.0.OR.X22.NE.0)GO TO 5511
IF(JA.LT.0)GO TO 55
C GOES BACK IF NEGATIVE AND NOT IN EDIT MODE.
IF(JA.GE.23.AND.JA.LE.26)GO TO 7555
IF(JA.EQ.22.OR.JA.EQ.33)GO TO 42
IF(JA.EQ.44)GO TO 44
IF(JA.EQ.55)GO TO 554
CC IF(JA.EQ.133)GO TO 6554
IF(JA.EQ.12.OR.JA.EQ.13)GO TO 120
IF(IABS(JC).GT.5.OR.(IABS(JD).GT.50.AND.JA.GT.2.AND.
1 JA.NE.9.AND.JA.NE.10))GO TO 55
C CATCHES SOME TYPO ERRORS IN P3 AND P4.
C AVOIDS EXIT AFTER TYPO ERROR
IF(JA.EQ.18)GO TO 80
IF(JA.EQ.21.OR.JA.EQ.19)GO TO 61
IF(JA.GT.13.AND.JA.LT.18)GO TO 88
C NEXT 11 LINES REPLACE "GO TO 60" ADDED 2 APR.72
IF(JA.NE.27)GO TO 60
IF(RJB.EQ.0)GO TO 55
JA=24
C TO REDISPLAY WITH MAGNIFICATION
RSZ=.8571*RJB
JCEN=JC
KCEN=JD
RJB=0
RJC=0
RJD=0
GO TO 6531
C THE 11 LINES ABOVE ADDED 2 APR.72 PER LCS LETTER
6333 FORMAT(I4,')',10F8.3)
CC89 FORMAT(' BOTTOM=',I4,' TOP=',I4)
DO 6334 L=1,ITEM
X=PWDS(L)
Y=RN(X)+2+X
6334 PRINT 6333,L,(RN(K),K=X+1,Y)
CALL EXIT
172 CALL JUGGLE(X22)
272 CALL ACCPOG(1)
CALL DPYOUT(1)
IF(ZERO)GO TO 55
X22=ZERO
ZERO=-1
IF(KED.NE.0)GO TO 244
GO TO 425
7542 IF(X22.EQ.0)GO TO 9542
C FOR DELETES IN EDIT MODE
L=RN(MEDIT)+3
C SIZE OF DELETION
I=IX-L
CALL LOOP(MEDIT,IX-L,1,0,L,RN)
JY=WDS(X22+1)-WDS(X22)
CALL LOOP(WDS(X22)+2,WDS(ITEM),1,0,JY,ST)
RJF=L
DO 194 K=X22,ITEM-1
194 PWDS(K)=PWDS(K+1)-RJF
DO 294 K=X22+1,ITEM
294 WDS(K)=WDS(K+1)-JY
ITEM=ITEM-1
ST(2)=WDS(ITEM)
RJB=X22
ITEM=ITEM-1
JA=0
GO TO 73
8542 IF(X22.NE.0)GO TO 172
9542 IF(RJC.NE.0)GO TO 70
6542 ITEM=ITEM-1
IF(ITEM)ITEM=0
3551 ST(2)=WDS(ITEM+1)
I=PWDS(ITEM+1)
CALL ACCPOG(1)
CALL DPYOUT(1)
IF(JA.EQ.99)GO TO 5531
IF(JA.EQ.0)GO TO 55
GO TO 60
70 J=0
L=1
IF(RJC.EQ.10.)RJC=0
DO 71 K=1,ITEM
X=PWDS(K)+3
IF(RN(X).NE.RJC)GO TO 71
R(1,L)=22.
R(2,L)=K-J
J=J+1
R(1,L+1)=99.
R(1,L+2)=222.
R(2,L+2)=0
DO 271 X=3,8
DO 271 Y=L,L+2
271 R(X,Y)=0
IF(L.GT.45)GO TO 171
C 50 IS THE CURRENT R ARRAY LIMIT!!!
L=L+3
71 CONTINUE
171 R(1,L)=100.
READX=-1.
GO TO 653
IF(RJC.EQ.4.)RPOS(1,1)=0
C TO ERASE SPACING SCALE (STAFF #4)
C FOR EDITS*******
EDX=RJB
Y=PWDS(EDX)
JA=RN(Y+1)
RJB=RN(Y+2)
X=Y+2
MN=RN(Y)+1
DO 2553 K=MN,20
RJQ(K)=0
2553 JQ(K)=0
C CLEARS ARRAY
DO 1553 K=1,MN
RJQ(K)=RN(X+K)
1553 JQ(K)=RJQ(K)
C GETS DATA FROM N ARRAY.
1552 GO TO 60
91 CALL ACCPOG(1)
IF(I.EQ.IX)ITEM=ITEM-1
GO TO 142
C 55,POS -- SETS UP ALIGNMENT
554 RJC=RJB*5.96-596.
JB=RJC
CALL BOX(RJC,999.0)
KED=-1
RLINE=RJB
GO TO 45
C '22,0' EDITS LAST ITEM ENTERED
42 IF(RJB.NE.0)GO TO 428
X22=ITEM
GO TO 429
44 KED=1
45 REDIT=RJB
C THE STAFF #
JED=1
244 X=ITEM
IF(JED.GT.X)GO TO 444
DO 144 K=JED,X
L=PWDS(K)
IF(KED)GO TO 654
IF(RN(L+3).EQ.REDIT)GO TO 344
GO TO 144
654 IF(ABS(RLINE-RN(L+2)).LT.5.0)GO TO 344
144 CONTINUE
444 REDIT=999.
C NO MORE ON LINE
GO TO 73
344 JED=K+1
C FOR NEXT TIME AROUND
X22=K
GO TO 429
C CR MOVES ALONG GIVEN LINE, 222 LEAVES THIS MODE
428 IF(JA.NE.33)GO TO 242
C 33,POS,STAFF -- EDITS BY POSITION.
DO 342 K=1,ITEM
L=PWDS(K)
IF(RN(L+3).NE.RJC.OR.ABS(RN(L+2)-RJB).GT.4..OR.
1 (RJD.NE.0.AND.RN(L+1).NE.RJD))GO TO 342
X22=K
GO TO 425
342 CONTINUE
GO TO 55
242 IF(X22.GT.0)GO TO 5511
142 IF(RJB.NE.0)GO TO 424
IF(REDIT.NE.999..AND.JA.GE.0)GO TO 244
X22=X22+1
IF(JA)X22=X22-1+JA
IF(X22.LT.1)X22=1
GO TO 425
424 X22=RJB
425 IF(X22.GT.ITEM)GO TO 73
C LEAVES EDIT MODE.
429 IX=I
MEDIT=PWDS(X22)
J=2
426 Y=RN(MEDIT)+J
CALL LOOP(0,Y,1,I,MEDIT,RN)
JJA=RN(I+1)
YED=Y-2
DO 422 K=1,20
IF(K.GT.YED)GO TO 423
RJJ(K)=RN(I+K+2)
GO TO 422
423 RJJ(K)=0
422 CONTINUE
RJJB=RN(I+2)
JC=RJJ(1)
RBOX=STF(JC+4)
CALL BOX(RJJB,RBOX)
ITEM=ITEM+1
ST(2)=WDS(ITEM)
GO TO 55
427 FORMAT(F4.0,F7.2,F4.0,$)
4271 FORMAT('+ (',I2,')',F7.2,$)
211 IF(RJB.NE.0)GO TO 72
RJB=RLINE
GO TO 7221
C FOR '55' ALIGNING
C PUTS ITEM ON STAFF 3.
C FOR EDITING
5511 IF(JA.EQ.55.AND.KED)GO TO 211
IF(JA.GT.10.OR.JA.EQ.1)GO TO 55
C PARAM NUM TOO HIGH?
IF(JAB.NE.99)GO TO 4221
ITEM=ITEM+1
GO TO 3551
C '0' AFTER '99' RESTORES DELETED ITEM
C LOOKS FOR NEXT ITEM TO EDIT IF <CR>
CC4221 IF(X22.EQ.0)GO TO 5516
CC IF(RJB.NE.0)GO TO 5517
4221 IF(X22.EQ.0.OR.RJB.NE.0)GO TO 5517
C BACKS UP WHEN IN EDIT MODE.
IF(JA.GT.0)GO TO 5221
IF(I.EQ.IX)GO TO 91
ZERO=X22+1
C '0' AFTER AN EDIT ENDS THE EDIT AND GETS NEXT ITEM FOR EDIT.
72 IF(X22.EQ.0)GO TO 55
IF(KED.EQ.0)REDIT=999.
IF(I.NE.IX)GO TO 172
ITEM=ITEM-1
C TO DELETE AN ITEM
73 X22=0
CALL ACCPOG(1)
CALL DPYOUT(1)
IF(JA.EQ.55.AND.REDIT.NE.999.)GO TO 554
IF(RJB.EQ.0.OR.RJB.GT.ITEM)GO TO 55
GO TO 424
C DELETION IN EDIT MODE DOES NOT LEAVE MODE.
5221 IF(JA.EQ.2)GO TO 7221
GO TO 5518
CC5516 IF(RJB.EQ.0)GO TO 55
5517 IF(JA.EQ.0)GO TO 6221
5518 IF(JA.EQ.2)GO TO 7221
IF(JA.GE.22)GO TO 55
RJJ(JA-2)=RJB
RJB=RJJB
GO TO 6222
7221 RJJB=RJB
6222 IF(JQ(1).EQ.0)GO TO 6221
C ARRAYS NEED 2O LOCATIONS HERE.
C CHNG PARAMS WITH PAIRS OF NUMS.(EG. 2,122 4,13 5,-2 ETC.)
DO 1222 K=1,20,2
L=JQ(K)
IF(L-2)6221,2222,3222
3222 RJJ(L-2)=RJQ(K+1)
GO TO 1222
2222 RJJB=RJQ(K+1)
RJB=RJJB
1222 CONTINUE
C*** LOOP SET TO 10 (20 IN ARRAY!)
6221 DO 5514 K=1,10
RJQ(K)=RJJ(K)
5514 JQ(K)=RJQ(K)
IF(JA.NE.0)GO TO 6515
IF(JJA.EQ.9.OR.JJA.EQ.8)GO TO 5515
IF(JJA.NE.4.OR.RJF.EQ.0)GO TO 7515
C ABOVE FOR P1=9 (BEAMS, SLURS, LINES)
5515 RJF=RJF+RJB
JQ(4)=RJF
IF(RJI.NE.0)RJI=RJI+RJB
JI=RJI
C RJI IS LOC. OF INNER NOTE IN BEAM RANGE.
7515 RJB=RJB+RJJB
6515 JA=JJA
GO TO 6542
6554 CALL PLOTS(K)
CALL PLOT(IFIX(RJB),JC,3)
C TO MOVE PLOTTER: 133, X, Y
GO TO 55
C MOVES SECTIONS TO RIGHT OR LEFT AND JUSTIFIES.
7555 IF(JA.NE.26)GO TO 5551
JX=0
MX=ITEM-RJB+1
JY=ITEM
IF(JF.EQ.0)GO TO 75553
MX=JF
JY=RJB+JF-1
75553 IF(RJE.EQ.0)GO TO 75551
JX=-1
IF(RJE.EQ.10.)RJE=0
75551 DO 75552 K=MX,JY
L=PWDS(K)
RA=RN(L+1)
IF(RA.EQ.10.)GO TO 75552
C '26' WON'T WORK WITH '10'(STAFF LINES)
IF(JX)RN(L+3)=RJE
X=L+2
RN(X)=RN(X)+RJC
X=L+4
IF(RA.NE.2.)RN(X)=RN(X)+RJD
IF((RA.NE.4.AND.RA.NE.8.AND.RA.NE.9).OR.RN(L).LT.4)GO TO 75552
X=L+5
RN(X)=RN(X)+RJD
X=L+6
RN(X)=RN(X)+RJC
IF(RN(L).LT.7.)GO TO 75552
X=L+9
RN(X)=RN(X)+RJD
75552 CONTINUE
GO TO 8551
5551 X=1
L=X
MX=-1
IF(JH.NE.0)L=I
IF(RJG.EQ.10.)RJG=0
C STF CHANGE TO 10=0
IF(JF.EQ.0)JE=JC
7554 RJJB=JE
DISX=0
IF(JF.NE.0)DISX=FLOAT(JF-JE)/(RJC-RJB)
IF(RJB+RJC.EQ.0)GO TO 8551
6551 RB=RN(X)
IF(RN(X+3).NE.JD.AND.JD.LT.10)GO TO 7551
DIS=RN(X+2)
IF(DIS.LT.RJB.OR.DIS.GT.RJC)GO TO 7551
C IF JH>0 MOVE TO NEW SPOT AND LEAVE OLD BEHIND.
IF(JH.EQ.0)GO TO 9551
K=RB+2
CALL LOOP(0,K,1,L,X,RN)
ITEM=ITEM+1
PWDS(ITEM+1)=L+K+1
9551 RA=RN(X+1)
POS=-1
IF(RA.EQ.4..OR.RA.EQ.8..OR.RA.EQ.9.)POS=0
CC IF(MX)MX=X
IF(JA.EQ.25)GO TO 1551
IF(JG.NE.0)RN(L+3)=RJG
C RJG IS NEW STAFF NUM.
IF(JF.EQ.0)GO TO 2551
RN(L+2)=RJE+(DIS-RJB)*DISX
IF(POS)GO TO 7552
IF(RA.EQ.4..AND.RB.EQ.2)GO TO 7552
RN(L+6)=RJE+(RN(X+6)-RJB)*DISX
IF(RB.EQ.8.)RN(L+9)=RJE+(RN(X+9)-RJB)*DISX
C ONLY TRUE WHEN RA=9
GO TO 7552
1551 IF(RB.LT.3..AND.RN(X+1).NE.6.)GO TO 7551
RN(X+4)=RN(X+4)+RJE
IF(POS.EQ.0)RN(X+5)=RN(X+5)+RJE
GO TO 7551
2551 RN(L+2)=DIS+RJE
IF(RA.EQ.9..OR.RA.EQ.8..OR.(RA.EQ.4..AND.RB.NE.2.))
1 RN(L+6)=RN(X+6)+RJE
IF(RB.EQ.8.)RN(L+9)=RN(X+9)+RJE
7552 L=RB+3+L
7551 X=RB+3+X
IF(JH.EQ.0)L=X
IF(X.LT.I)GO TO 6551
CC8551 ST(2)=3
8551 I=PWDS(ITEM+1)
CC IF(MX)MX=1
CC ITEM=MX-1
ITEM=0
CC ST(2)=WDS(MX)
CC M=MX
8552 PLT=1
ST(2)=3
EDX=0
IF(JA.NE.24)GO=0
CALL ACCPOG(1)
CC IF(PLT.EQ.1)GO TO 6120
GO TO 6120
CC CALL DPYOUT(1)
CC GO TO 55
60 RJJB=RJB
JJA=JA
IF(JA.EQ.1.AND.RJH.EQ.0)RJQ(6)=999.
C 999=0 FOR STEM EXTENSIONS.
DO 5543 K=1,20
5543 RJJ(K)=RJQ(K)
CNT=1
C USES ONLY 10 PARAMETERS.
DO 1554 K=10,1,-1
IF(RJQ(K).EQ.0)GO TO 1554
CNT=K
GO TO 2554
1554 CONTINUE
2554 IF(PLT.NE.0)GO TO 5541
IF(JA.EQ.9.OR.JA.EQ.1)CALL HOMER
IF(JA.NE.6.OR.RJF.EQ.0)GO TO 261
DO 16 K=1,ITEM
L=PWDS(K)
IF(RN(L+1).NE.1..OR.RN(L+3).NE.RJC)GO TO 16
RA=RN(L+2)
IF(ABS(RA-RJB).GT.3.)GO TO 16
CC IF(ABS(RA-RJB).GT.4..OR.ABS(RN(L+4)-RJD).GT.3.)GO TO 16
RB=ABS(RJE)
RJB=RA
C NEXT IS FOR STACCATO
IF(RB.EQ.0)RJB=RA+.85
IF(RB.EQ.4.)RJB=RA+1.
C FOR WEDGE ACCENT
IF(RB.EQ.6.OR.RB.EQ.7)RJB=RA-.35
C FOR FERMATA
GO TO 261
C MAKES DOTS, ACCENTS, ETC. HOME IN ON NOTES IF P6=1.
16 CONTINUE
C **** FOR '0' EDITS ******
261 RN(I)=CNT
RN(I+1)=JA
RN(I+2)=RJB
I=I+2
DO 4554 K=1,CNT
4554 RN(I+K)=RJQ(K)
3554 I=CNT+1+I
C WHAT ABOUT EDITS?*******
5541 POS=STF(JC+4)
JB=RJB*5.96-596
C LINE IS DIVIDED INTO 200 POINTS.
CENTR=POS
551 IF(JA.EQ.4.OR.JA.EQ.10)GO TO 25
IF(JA.LE.11.OR.JA.EQ.30)GO TO 11
IF(JA.NE.50.AND.JA.NE.20)GO TO 120
CALL ALPHA
GO TO 57
C TO PLOT: DO A SAVE(JA=1000), THEN: 13, SIZE FACTOR. TO GET DISPLAY: 12
120 IF(PLOTIT.AND.JA.EQ.13)GO TO 5121
IF(I.NE.1.AND.RJC.EQ.0)GO TO 55
C GUARDS AGAINST LOSSAGE!
PLOTIT=-1
GO TO 1
2005 IF(NAME.EQ.' ')GO TO 2200
CALL IFILE(21,NAME)
2200 IF(RJC.NE.0)GO TO 2203
2202 READ(21),ITEM,
1 I,(PWDS(K),K=1,ITEM+1),(RN(K),K=1,I-1),ISCR,(V(K),K=1,ISCR),
1 LCNT,(LIST(K),K=1,LCNT)
GO TO 2201
2203 J=ITEM+1
C FOR COMBINING FILES
READ(21),X,Y,(PWDS(K),K=J,X+J)
1,(RN(K),K=I,I+Y-2),ISCR,(V(K),K=1,ISCR),
1 LCNT,(LIST(K),K=1,LCNT)
RA=I-1
DO 2204 K=J,J+X
2204 PWDS(K)=PWDS(K)+RA
ITEM=ITEM+X
I=PWDS(ITEM+1)
2201 DO 2011 K=I,2000
2011 RN(K)=0
IF(JA.NE.13)GO TO 5551
5121 CALL PLTSRT
NOMOVE=JF
C IF P5=0 MOVES UP AT START, IF P6=0 MOVES UP AT END.
PLT=-1-JD
M=I
I=I+M-1
CALL PLOTS(K)
IF(RJB.EQ.0)RJB=100.
DIS=RJB*.01030
IF(RJC.EQ.0)RJC=RJB
RHT=RJC*.010
BOT=-BOT*RHT
IF(RJE.EQ.0)CALL PLOT(0,BOT,-3)
C MOVES PLOTTER UP IF P5=0.
CC CALL PLOTS(K)
C NEXT RUNS THROUGH DATA WITH NEW CHANGES.
6120 IF(M.GE.I)GO TO 7120
CNT=RN(M)
C CLEARS INPUT ARRAY, USES ONLY 12 PARAMS.
DO 6220 K=CNT+1,20
JQ(K)=0
6220 RJQ(K)=0
JA=RN(M+1)
RJB=RN(M+2)
M=M+2
DO 9120 K=1,CNT
RJQ(K)=RN(M+K)
9120 JQ(K)=RJQ(K)
8120 M=CNT+M+1
IF(EDX.LE.0)GO TO 60
GO TO 55
7120 M=1
IF(EDX)GO TO 71201
IF(PLT.EQ.1)EDX=-1
PLT=0
GO TO 55
71201 TOP=TOP*DIS*1.1+50
IF(NOMOVE.NE.0)TOP=0
CALL PLOT(0,TOP,3)
C MOVES PLOTTER UP
CALL EXIT
61 CALL HOMER
GO TO 8551
C METER NUMBERS.
80 CALL METER(READX)
GO TO 653
11 CALL NOTWRT
GO TO 57
25 CALL ITMSUB
C WHOLE & HALF REST, BAR LINES, BEAMS, STAFF LINES ****
GO TO 57
101 REWIND 21
SAVER=5
GO TO 102
1 FORMAT(I,24F)
TYPE 21
ACCEPT 22,NAME
IF(NAME.EQ.'-1'.OR.NAME.EQ.'99')GO TO 55
REWIND 21
IF(JA.NE.1000)GO TO 2005
IF(NAME.NE.' ')CALL OFILE(21,NAME)
IF(RJB.NE.0)GO TO 202
102 WRITE(21),ITEM
1,I,(PWDS(K),K=1,ITEM+1),(RN(K),K=1,I-1),ISCR,(V(K),K=1,ISCR),
1 LCNT,(LIST(K),K=1,LCNT)
1001 END FILE 21
IF(JA.NE.1000)GO TO 553
IF(NAME.EQ.' ')TYPE 5600
GO TO 55
202 WRITE(21),ST(2),(ST(K),K=1,ST(2)+2)
GO TO 1001
C WRITES DPY BUFFER ONLY.
5600 FORMAT(' DISPLAY SAVED IN ''FOR21.DAT'''/)
56 FORMAT(/1XA5,' TYPE FOR ITEM #',I3,I/)
21 FORMAT(' FILE NAME?'/)
22 FORMAT(A5)
END
SUBROUTINE NOTWRT
IMPLICIT INTEGER(A-Q,S-Z)
COMMON/SCM/V(200),LIST(78),ISCR,LCNT,RSTF,R(8,50)
DIMENSION SU(194),CLEFQ(3),CLEFX(77),CLEFY(77),ACNTX(6),ACNTY(6)
1 ,CMINI(4)
REAL DIS,PWDS,DISX,CENTR,POS,STF
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,ST(2800)
1,RJB,HGT,JJB,POS,JA,CENTR,J,JB,JY,K,RJQ(20),X,Y,L,CNT,DISX,JX
1,JQ(20),WDS(200),IX,MEDIT,RJJ(20),STF(8)
COMMON/NW/DAX(10),DAY(10),NX(11),NY(11),SHX(8),SHY(8)
1,FLX(7),FLY(7),NATX(6)
1, NATY(6),EX(6),EY(6),QX(10),QY(10),FILY(14),TAILX(6),TAILY(6)
COMMON /NU/NUMQ(42),NUMX(311),NUMY(311)
COMMON /NX/FERMX(15),FERMY(15)
EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJD,RJQ(2))
1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
1,(JK,JQ(9)),(JF,JQ(4)),(RJE,RJQ(3)),(SU(1),R(1,1)),(RJH,RJQ(6))
1,(RJG,RJQ(5))
DATA CLEFX/33,116,12,8,8,10,16,24,30,32,30,24,16,8,2,0,
1 2,4,23,23,22,20,16,13,12,22,20,16,12,10,11,16,18
1,56,107,13,21,26,28,28,27,25,20,15,10,5,2,0,0,1,2,5,8,11,13,14
1, 77,100,0,1,1,2,2,106,6,107,19,25,25,19,7,107,19,25,25,19,7/
1, CLEFY/33,12,12,16,22,26,30,30,26,18,10,4,2,4,10,18,
1 26,30,70,74,78,80,80,78,74,-10,-14,-16,-14,-10,-6,-4,-6
1,56,9,12,19,27,35,41,47,51,54,55,54,52,49,45,
1 43,39,37,35,35,36,38,41, 77,5,57,5,57,5,57,57,5,7,7,14,20
1,29,29,35,35,42,48,55,55/
1 ,CLEFQ/1,34,57/,ACNTX/100,14,0,97,1,5/,ACNTY/4,0,-4,0,14,0/
1,CMINI/4,10,6,6/
C TREB=1-33,BASS=34-56, C CLEF=57-77
1 CENTR=POS-18+AMOD(RJD,100.0)*7.0
RMINI=1.
IF(JA.EQ16,8,2,0,
1 2,4,23,23,22,20,16,13,12,22,20,16,12,10,11,16,18
1,56,107,13,21,26,28,28,27,25,20,15,10,5,2,0,0,1,2,5,8,11,13,14
1, 77,100,0,1,1,2,2,106,6,107,19,25,25,19,7,107,19,25,25,19,7/
1, CLEFY/33,12,12,16,22,26,30,30,26,18,10,4,2,4,10,18,
1 26,30,70,74,78,80,80,78,74,-10,-14,-16,-14,-10,-6,-4,-6
1,56,9,12,19,27,35,41,47,51,54,55,54,52,49,45,
1 43,39,37,35,35,36,38,41, 77,5,57,5,57,5,57,57,5,7,7,14,20
1,29,29,35,35,42,48,55,55/
1 ,CLEFQ/1,34,57/,ACNTX/100,14,0,97,1,5/,ACNTY/4,0,-4,0,14,0/
1,CMINI/4,10,6,6/
C TREB=1-33,BASS=34-56, C CLEF=57-77
1 CENTR=POS-18+AMOD(RJD,100.0)*7.0
RMINI=1.
IF(JA.EQ OF MINI CLEFS
812 IF(JD.NE.4)GO TO 811
JY=JY+13
JD=3
811 CALL DRAW(CLEFQ(JD)+1,CLEFX(CLEFQ(JD)),CLEFX,RMINI,JB,CLEFY,JY)
C CALL DRAW(LOOP1,LOOP2,X,MULTIPLIER,ADDER,Y,ADDER) MULT ALSO MULTS Y!
IF(JD.NE.2)RETURN
CC IF(RMINI.NE.1.)RMINI=.7
C NEXT IS FOR BASS CLEF DOTS.
81 RJX=JB+34*RMINI
RJY=POS+52
108 RJF=RJY-3
RX=1
CALL LINES(RJX,RJY,3)
DO 8 K=0,2
RA=RJX+K
CALL LINES(RA,RJF,2)
IF(K.EQ.2)RX=-3
8 CALL LINES(RA+RX,RJY,2)
IF(JA.EQ.1)GO TO 1342
RB=POS+52.
IF(JA.NE.2.OR.RJY.NE.RB)RETURN
RJY=RJY-12
GO TO 108
C ABOVE FOR DOTS
291 RJB=JB+9
IF(JE.EQ.8.OR.INV)CENTR=CENTR-3
C REMOVE '8' LATER
CENTR=CENTR+2
29 RJX=RJB
RJY=CENTR+1
GO TO 108
C ACCENTS
28 X=1
Y=3
RA=1.
IF(INV)RA=-RA
JX=0
IF(JE.NE.6)JX=3
CALL DRAW(X+JX,Y+JX,ACNTX,RA,JB,ACNTY,IFIX(CENTR))
RETURN
C >=6, ∧=5
27 RJB=JB
CALL LINES(RJB,CENTR,3)
C DASHES
CALL LINES(RJB+14.0,CENTR,2)
RETURN
C FOR LEDGER LINES
70 JJ=JD
170 RJW=RJB-9.*RMINI
RJZ=RJB+22.*RMINI
IF(JJ)GO TO 71
JX=JJ
JY=13
GO TO 711
71 JX=-JJ
JY=JJ*2+3
711 RX=POS-18+7*JY
IF(JF)RJZ=RJZ+2*RMINI
126 IF(PLT.EQ.-3)GO TO 1126
C FOR 2-PASS PLOTTING
IF(PLT.EQ.-2)PLT=-4
CALL LINES(RJW,RX,3)
CALL LINES(RJZ,RX,2)
IF(PLT.EQ.-4)PLT=-2
1126 IF(JX.EQ.1)GO TO 1122
RX=RX+14
JX=JX-1
GO TO 126
1122 IF(JA.EQ.7)RETURN
JI=-1
GO TO 1121
30 JE=JE+7
IF(JE.LT.5)JE=JE-3
CENTR=CENTR+19.
IF(JE.GT.9)CENTR=CENTR+13.
C P4 CAN MOVE REST UP-DOWN BY WHOLE SPACES.
11 RJB=JB
CALL LINES(RJB,CENTR,3)
IF(JA.NE.1) GO TO 241
C SKIPS IF RESTS ARE WANTED.
C NOTES****
1011 IF(IABS(JD).LT.100)GO TO 1221
RMINI=.6
C FOR RMINI NOTES
JD=MOD(JD,100)
1221 IF((JD.GT.1.AND.JD.LT.13).OR.JI.NE.0)GO TO 1121
JJ=(JD+1)/2-6
IF(JJ)JJ=-((3-JD)/2)
GO TO 170
C IF JF≠0 NOTE IS FILLED IN
1121 IF(JF.GE.0)GO TO 125
CALL DRAW(1,11,NX,RMINI,JB,NY,IFIX(CENTR))
GO TO 123
125 RJ=CENTR+FILY(1)*RMINI
CALL LINES(RJB,RJ,3)
Y=4
IF(PLT)Y=2
RX=Y/2
RA=CENTR
DO 124 K=0,13,Y
JJB=K+1
RC=K*RMINI+RJB
RJX=FILY(JJB+1)*RMINI
RJZ=CENTR-FILY(JJB)*RMINI
CALL LINES(RC,RJZ,2)
CALL LINES(RC+RX,CENTR-RJX,2)
IF(PLT.GE.0)GO TO 124
CALL LINES(RC+1.0,CENTR+RJX,2)
IF(JJB.EQ.13)GO TO 123
RJZ=CENTR+FILY(JJB+2)*RMINI
CALL LINES(RC+2.0,RJZ,2)
124 CONTINUE
CENTR=CENTR
123 RJE=RJE-JE
C RJE=STEPS TO LEFT FOR ACCID.
IF(JE.LT.10)GO TO 1242
128 JG=MOD(JG,10)
RG=(JG-1)*12
IF(RG)RG=0
IF(RJH.GE.999)RJH=0
RH=RJH*7.
C STEM EXTENSIONS ARE BY NOTE #S
IF(JE.GT.19)GO TO 122
C NEXT IS FOR STEM UP.
1280 RJX=RJB+13.*RMINI
IF(JF.NE.0)RJX=16*RMINI+RJB
IF(PLT.EQ.-3)GO TO 227
IF(PLT.EQ.-2)PLT=-4
CALL LINES(RJX,CENTR,3)
RJZ=CENTR+RH+(58+RG)*RMINI
CALL LINES(RJX,RJZ,2)
IF(PLT.EQ.-4)PLT=-2
227 JE=JE-10
IF(JG.EQ.0)GO TO 1242
RJY=CENTR+(58+RG)*RMINI+RH
127 DO 1128 L=1,2
DO 1127 K=1,6
RJ=RJX+TAILX(K)*RMINI
RJZ=RJY-TAILY(K)*RMINI
1127 CALL LINES(RJ,RJZ,2)
IF(PLT.GE.0.OR.RMINI.LT.1.)GO TO 1028
C MAKES THINNER TAILS
1128 RJY=RJY-1.
1028 JG=JG-1
IF(JG.EQ.0)GO TO 327
RJY=RJY-11
CALL LINES(RJX,RJY,3)
GO TO 127
327 IF(RMINI.EQ.1..OR.RJG.GT.1.)GO TO 1242
RJY=RJZ-19
RJZ=RJZ-4
IFS FOR STEM UP.
1280 RJX=RJB+13.*RMINI
IF(JF.NE.0)RJX=16*RMINI+RJB
IF(PLT.EQ.-3)GO TO 227
IF(PLT.EQ.-2)PLT=-4
CALL LINES(RJX,CENTR,3)
RJZ=CENTR+RH+(58+RG)*RMINI
CALL LINES(RJX,RJZ,2)
IF(PLT.EQ.-4)PLT=-2
227 JE=JE-10
IF(JG.EQ.0)GO TO 1242
RJY=CENTR+(58+RG)*RMINI+RH
127 DO 1128 L=1,2
DO 1127 K=1,6
RJ=RJX+TAILX(K)*RMINI
RJZ=RJY-TAILY(K)*RMINI
1127 CALL LINES(RJ,RJZ,2)
IF(PLT.GE.0.OR.RMINI.LT.1.)GO TO 1028
C MAKES THINNER TAILS
1128 RJY=RJY-1.
1028 JG=JG-1
IF(JG.EQ.0)GO TO 327
RJY=RJY-11
CALL LINES(RJX,RJY,3)
GO TO 127
327 IF(RMINI.EQ.1..OR.RJG.GT.1.)GO TO 1242
RJY=RJZ-19
RJZ=RJZ-4
IF(RJX.NE.RJB-1)GO TO 1327
RJY=RJZ+29
RJZ=RJZ+4
1327 RJX=RJX-7
CALL LINES(RJX,RJY,3)
CALL LINES(RJX+23.0,RJZ,2)
C FOR SLASH ON GRACE NOTE TAIL
GO TO 1242
C NEXT IS FOR STEM DOWN.
122 IF(PLT.EQ.-3)GO TO 322
IF(PLT.EQ.-2)PLT=-4
CALL LINES(RJB,CENTR,3)
RJZ=CENTR-RH-(58+RG)*RMINI
CALL LINES(RJB,RJZ,2)
IF(PLT.EQ.-4)PLT=-2
322 JE=JE-20
IF(JG.EQ.0)GO TO 1242
RJX=RJB-1
RJY=CENTR-(58+RG)*RMINI-RH
129 CALL LINES(RJB,RJY,3)
DO 1130 L=1,2
DO 1129 K=1,6
C THIS, AND STUFF AT 127 MIGHT GO INTO SEP. SUBROUTINE.
RJ=RJB+TAILX(K)*RMINI
RJZ=RJY+TAILY(K)*RMINI
1129 CALL LINES(RJ,RJZ,2)
IF(PLT.GE.0.OR.RMINI.LT.1.)GO TO 1030
1130 RJY=RJY+1.
1030 JG=JG-1
IF(JG.EQ.0)GO TO 327
RJY=RJY+11.
GO TO 129
1242 IF(RJG.LT.10.)GO TO 1342
C FOR DOTTED NOTE-- P7>9
RJX=RJB+24.*RMINI+AMOD(RJG,1.0)*59.6
RJY=CENTR+1.
IF(MOD(JD,2).NE.0)RJY=RJY+7.
GO TO 108
1342 RJB=RJB-RJE*59.6
C TO SPACE OUT ACCIDS.
IF(RMINI.NE.1.)RMINI=.7
242 JE=JE+1
IF(JE.GT.0)GO TO 2421
INV=-1
JE=2-JE
2421 IF(JA.EQ.6)GO TO (29,241,241,241,28,28,243,243,60,27),JE
C DOT, b, #, NAT, ACC ∧, ACC >, FERMATA, FERM INV., REP MEAS., DASH
241 IF(JA.NE.11)GO TO 21
CALL MSSUB(RJB,CENTR,RJQ)
C TO ADD USER SUBROUTINE (RJB=X COORD., CENTR=Y COORD.)
RETURN
21 J=7
IF(IABS(JD).LT.100)GO TO 1241
JD=MOD(JD,100)
RMINI=.7
1241 GO TO (57,22,23,24,25,25,22,22,22,22,22),JE
24 J=6
GO TO 22
243 J=15
JX=4
GO TO 222
23 J=8
22 JX=J-5
IF(JE.EQ.7)J=10
IF(JE.GE.8)J=6
JJB=31
222 DO 221 K=1,J
JK=3
GO TO (31,32,33,324),JX
C NATURAL SIGN
31 RX=NATX(K)*RMINI
RY=NATY(K)*RMINI
L=3
GO TO 34
C FLATS
32 IF(JE.EQ.7)GO TO 320
IF(JE.GE.8)GO TO 321
RX=FLX(K)*RMINI
RY=FLY(K)*RMINI
GO TO 323
C QUARTER REST
320 RX=QX(K)
RY=QY(K)+30
GO TO 323
C EIGHTH REST (AND SIXTEENTH)
321 RX=EX(K)
RY=EY(K)+JJB
323 L=1
GO TO 34
C FERMATA
324 RX=FERMX(K)
RY=FERMY(K)
IF(JE.EQ.8.OR.INV)RY=-RY
C REMOVE '8' LATER
C JE=8(7 IN PARAM LIST)=INVERTED FERMATA
GO TO 323
C SHARPS
33 RX=SHX(K)*RMINI
RY=SHY(K)*RMINI
L=2
34 RX=RX+RJB
RY=RY+CENTR
35 IF(K.EQ.1)GO TO 221
CC JY=MOD(K,L)
CC IF(JY.NE.1)JK=2
IF(MOD(K,L).NE.1)JK=2
221 CALL LINES(RX,RY,JK)
IF(JX.EQ.4)GO TO 291
C PUTS DOT IN FERMATA
IF(JE.GE.9)GO TO 500
501 IF(JA.NE.3.OR.RJF.EQ.0)RETURN
L=20
IF(JE.GE.5.AND.JE.LE.6)L=25
JB=JB+L
RJD=8.
JA=6
JE=0
C IF P6=1 THE REST IS DOTTED
GO TO 1
500 RJB=RJB-3
JJB=JJB-13
JE=JE-1
GO TO 222
C NUMBERS. 5, POS, STF, NOTE #, NUM, SIZE(100'S)
50 CNT=CENTR+3
DISX=RJE/100.
IF(DISX.EQ.0)DISX=1.
X=NUMQ(JF+1)
C TXX=END # OF ITEM
C TXX+1=1ST PART OF ITEM
CALL DRAW(X+1,NUMX(X),NUMX,DISX,JB,NUMY,CNT)
IF(JE.EQ.9)GO TO 63
IF(JA.EQ.101)GO TO 1005
RETURN
110 JC=RJB
IF(JC.NE.99)GO TO 1008
CALL HYDPOG(2)
RETURN
1008 JF=0
C SETS UP SCALE LINES.
RJC=STF(JC+4)+60
RJ=RJC+60
CENTR=RJC+74
CALL DPYSET(2,SU,194)
CALL DPYBRT(1)
1001 POS=RJC+64
DO 1002 MX=10,200,10
RA=MX*5.96-596
JB=RA-58
IF(MX.GT.10)GO TO 50
1005 CALL LINES(RA,RJC,3)
CALL LINES(RA,RJ,2)
JF=JF+1
1002 IF(JF.EQ.10)JF=0
CALL LINES(-596.0,RJ,2)
CALL LINES(-596.0,RJC,2)
1007 CALL DPYOUT(2)
CALL SETPOG(1)
RETURN
C FOR 1 OR 2 BAR REP SIGNS.
60 RA=CENTR+35
CALL LINES(RJB,RA,3)
DO 61 K=1,5
RJ=K+RJB
CALL LINES(RJ+28.0,RA+28.0,2)
IF(K.EQ.5)GO TO 62
61 CALL LINES(RJ,RA,2)
62 RJE=100.
JF=38
CENTR=RA+21
JB=JB+4
GO TO 50
63 IF(CENTR.NE.RA+21.0)RETURN
JB=JB+23
CENTR=CENTR-14
GO TO 50
END
C ********** WHOLE & HALF RESTS, BEAMS ******
C LOAD MSS, NOTWRT, ITMSUB, PLTSRT **** IN THAT ORDER!!!!
SUBROUTINE ITMSUB
IMPLICIT INTEGER(A-Q,S-Z)
REAL DIS,PWDS,DISX,HGT,POS,CENTR,STF
COMMON/MIN/MINI,RMINI
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,ST(2800)
1,RJB,HGT,JJB,POS,JA,CENTR,J,JB,JY,K,RJQ(20),X,Y,L,CNT,DISX,JX
1,JQ(20),WDS(200),IX,MEDIT,RJJ(20),STF(8)
EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJE,RJQ(3))
1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
1,(JK,JQ(9)),(JF,JQ(4)),(RJI,RJQ(7))
RJBQ=JB
JY=0
IF(JA.EQ.4)GO TO 40
GO TO (90,100),JA-8
GO TO (25,26),JE-4
25 CENTR=CENTR+39
C WHOLE REST****
GO TO 251
26 CENTR=CENTR+30
C FOR HALF REST****
251 RJ=RJBQ+16
CC RJI=CENTR
CALL LINES(RJBQ,CENTR+1.0,3)
DO 252 K=1,5
RJE=CENTR+K
CALL LINES(RJ,RJE,2)
CALL LINES(RJ,RJE+1.0,2)
CALL LINES(RJBQ,RJE+1.0,2)
IF(K.EQ.3)RETURN
252 CALL LINES(RJBQ,RJE+2.0,2)
40 IF(PLT.EQ.-3)RETURN
RA=0
RX=POS+2
IF(RJF.GT.0)GO TO 401
C FOR BAR LINES
IF(JG)GO TO 407
RY=RX+58
IF(JD.GT.1)RY=RY+STF(JD+JC+3)-STF(JC+4)
RW=RY
RJX=RJBQ
421 IF(PLT.EQ.-2)PLT=-4
42 CALL LINES(RJBQ,RX,3)
IF(JG.EQ.-2)GO TO 404
C IF JG<0 THEN WIGGLEY LINES ARE MADE.
406 CALL LINES(RJX,RY,2)
IF(JG.EQ.0)GO TO 43
C FOR 'HEAVY' LINE.
JG=JG-1
RY=RW
IF(JG.EQ.2.OR.JG.EQ.0)GO TO 406
RY=RX
RJX=RJX+1
GO TO 406
43 IF(PLT.EQ.-4)PLT=-2
IF(RA.GT.0)GO TO 403
RETURN
C DRAWS BAR LINES. JD>0 CAUSES FULL LINE.
403 RA=RA-3.72
RJBQ=RJBQ+22
RJX=RJX+22
C **** BASED ON '596' ****
GO TO 42
C DASHES
401 IF(JG.EQ.0)GO TO 402
RA=RJF-RJB-4.
RJF=RJB+2
IF(JG.GT.0)JG=0
402 POS=POS-18
407 RX=RJQ(2)*7.+POS
RY=RJQ(3)*7.+POS
IF(JG.EQ.-1)GO TO 408
C FOR 'TR' JG=-2, 'ARPEGG' JG=-1
RJX=RJF*5.96-596.
GO TO 421
C DRAWS STRAIGHT LINES. ETC.
404 L=(RA+4)/1.5
RJ=RY
DO 405 K=1,L
CALL LINES(RJX,RJ,2)
RJX=RJX+9
RJBQ=RJ
RJ=RX
405 RX=RJBQ
RETURN
408 IF(RX.LT.RY)GO TO 409
RJ=RX
RX=RY
RY=RJ
409 RX=RX-12.
CALL LINES(RJBQ-4.0,RX-6.0,3)
410 CALL LINES(RJBQ+4.0,RX,2)
CALL LINES(RJBQ-4.0,RX+6.0,2)
RX=RX+12.
IF(RX.LT.RY)GO TO 410
RETURN
C VERTICAL WIGGLE
C NEXT IS F
GO TO 42
C DASHES
401 IF(JG.EQ.0)GO TO 402
RA=RJF-RJB-4.
RJF=RJB+2
IF(JG.GT.0)JG=0
402 POS=POS-18
407 RX=RJQ(2)*7.+POS
RY=RJQ(3)*7.+POS
IF(JG.EQ.-1)GO TO 408
C FOR 'TR' JG=-2, 'ARPEGG' JG=-1
RJX=RJF*5.96-596.
GO TO 421
C DRAWS STRAIGHT LINES. ETC.
404 L=(RA+4)/1.5
RJ=RY
DO 405 K=1,L
CALL LINES(RJX,RJ,2)
RJX=RJX+9
RJBQ=RJ
RJ=RX
405 RX=RJBQ
RETURN
408 IF(RX.LT.RY)GO TO 409
RJ=RX
RX=RY
RY=RJ
409 RX=RX-12.
CALL LINES(RJBQ-4.0,RX-6.0,3)
410 CALL LINES(RJBQ+4.0,RX,2)
CALL LINES(RJBQ-4.0,RX+6.0,2)
RX=RX+12.
IF(RX.LT.RY)GO TO 410
RETURN
C VERTICAL WIGGLE
C NEXT IS F
GO TO 42
C DASHES
401 IF(JG.EQ.0)GO TO 402
RA=RJF-RJB-4.
RJF=RJB+2
IF(JG.GT.0)JG=0
402 POS=POS-18
407 RX=RJQ(2)*7.+POS
RY=RJQ(3)*7.+POS
IF(JG.EQ.-1)GO TO 408
C FOR 'TR' JG=-2, 'ARPEGG' JG=-1
RJX=RJF*5.96-596.
GO TO 421
C DRAWS STRAIGHT LINES. ETC.
404 L=(RA+4)/1.5
RJ=RY
DO 405 K=1,L
CALL LINES(RJX,RJ,2)
RJX=RJX+9
RJBQ=RJ
RJ=RX
405 RX=RJBQ
RETURN
408 IF(RX.LT.RY)GO TO 409
RJ=RX
RX=RY
RY=RJ
409 RX=RX-12.
CALL LINES(RJBQ-4.0,RX-6.0,3)
410 CALL LINES(RJBQ+4.0,RX,2)
CALL LINES(RJBQ-4.0,RX+6.0,2)
RX=RX+12.
IF(RX.LT.RY)GO TO 410
RETURN
C VERTICAL WIGGLE
C NEXT IS FOR BEAMS
90 RMINI=1.
IF(IABS(JD).LT.100)GO TO 97
RMINI=.6
CC JD=MOD(JD,100)
RJE=AMOD(RJE,100.0)
97 RJA=JJ*10*RMINI
RJX=CENTR-58*RMINI+RJA
RJ=10*RMINI
RX=MOD(JG,10)-MOD(JH,10)
JJB=JG-20
RJF=RJF*5.96-596
RJY=7.*RJE+POS-18-58*RMINI+RJA
RA=ABS(RJI)*5.96-596.
IF(JG/10.EQ.2)GO TO 93
JJB=JG-10
RJ=-RJ
RJX=RJX+116*RMINI-2*RJA
RJY=RJY+116*RMINI-2*RJA
RJBQ=RJBQ+13*RMINI
RJF=RJF+13*RMINI
RA=RA+13*RMINI
93 IF(JJB.GT.RX)GO TO 94
C**********************
IF(JH.EQ.0)GO TO 94
RJC=13*RMINI
IF(RJI.EQ.0)GO TO 192
IF(JH.EQ.20)GO TO 193
RX=RJBQ-RA
GO TO 194
193 RX=RA-RJF
194 RJC=ABS(RX)
192 DISX=RJBQ-RJF
IF(DISX)DISX=-DISX
HGT=RJX-RJY
RJC=RJC/DISX
IF(HGT)GO TO 195
HGT=HGT*RJC
GO TO 196
195 HGT=HGT*RJC
196 Y=JH/10
JH=0
IF(Y.EQ.1)GO TO 95
C BEAM LFT=1, RT=2 (PARAM 8=10 OR 20)
RJBQ=RA
RJX=RJY+HGT
GO TO 94
95 RJF=RA
RJY=RJX-HGT
94 CALL LINES(RJBQ,RJX,3)
CALL LINES(RJF,RJY,2)
CALL LINES(RJF,RJY+1.0,3)
CALL LINES(RJBQ,RJX+1.0,2)
IF(RMINI.NE.1.)GO TO 940
CALL LINES(RJBQ,RJX+2.0,3)
CALL LINES(RJF,RJY+2.0,2)
IF(PLT.GE.0)GO TO 940
C DISPLAYS THINNER LINES THAN PLOTS
CALL LINES(RJF,RJY+3.0,3)
CALL LINES(RJBQ,RJX+3.0,2)
CALL LINES(RJBQ,RJX+4.0,3)
CALL LINES(RJF,RJY+4.0,2)
C DRAWS 5 LINES FOR BEAMS.
940 JJB=JJB-1
IF(JJB.LE.0)RETURN
C IF P7=10 OR 20 ONE BEAM WILL APPEAR.
RJY=RJY+RJ
RJX=RJX+RJ
GO TO 93
100 IF(PLT.EQ.-3)RETURN
RA=0
RJB=RJB*5.96-596
RJ=JD*5.96-596
IF(JD.EQ.0)RJ=596
C FOR STAFF LINES: 10, POS 1, HGT(3 TO -3), 2ND POS., UP-DOWN(NT #S)
STF(JC+4)=(JC+3)*123-369.+RJE*7.
JX=STF(JC+4)+3
JJB=JX+30
IF(PLT.EQ.-2)PLT=-4
DO 6 K=JX,JX+60,28
RX=K
CALL LINES(RJ,RX,3)
CALL LINES(RJB,RX,2)
IF(K.GT.JJB)GO TO 43
CALL LINES(RJB,RX+14.0,3)
6 CALL LINES(RJ,RX+14.0,2)
END
SUBROUTINE METER(READX)
IMPLICIT INTEGER(A-Q,S-Z)
REAL DIS,PWDS,DISX
COMMON/SCM/V(78),LIST(200),ISCR,LCNT,RSTF,R(8,50)
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,ST(2800)
1,RJB,RA,RB,RC,RD,CENTR,J,JB,JY,K,RJQ(20),X,Y,L,CNT,DISX,JX
1,JQ(20),WDS(200),IX,MEDIT,RJJ(20)
C NOTE COMMON CHANGES FOR THIS SUBROUTINE.
EQUIVALENCE(JD,JQ(2)),(JE,JQ(3)),(RJD,RJQ(2)),(RJE,RJQ(3))
1,(JA,RD)
C METER NUMBERS.
80 L=2
R(7,1)=RJB
R(7,2)=RJB
R(8,1)=8.
R(8,2)=4.
R(8,3)=4.
R(8,4)=4.
RJJ(1)=RJD
RJJ(2)=RJE
IF(JD.LT.10.AND.JE.LT.10)GO TO 84
L=3
RA=IFIX(RJD/10.)
RB=AMOD(RJD,10.0)
RC=IFIX(RJE/10.)
RD=AMOD(RJE,10.0)
IF(JE.GT.9)GO TO 82
C FOR 12/8 ETC.
R(7,2)=RJB+3.4
R(7,3)=RJB+1.7
R(8,2)=8.
RJJ(1)=RA
RJJ(2)=RB
RJJ(3)=RJE
GO TO 84
82 IF(JD.GT.9)GO TO 85
C FOR 4/16 ETC.
R(7,3)=RJB+3.4
R(7,1)=RJB+1.4
R(8,2)=4.
RJJ(2)=RC
RJJ(3)=RD
RJJ(1)=RJD
GO TO 84
85 L=4
R(7,2)=RJB+3.4
R(7,3)=RJB
R(7,4)=RJB+3.4
R(8,2)=8.
RJJ(1)=RA
RJJ(2)=RB
RJJ(3)=RC
RJJ(4)=RD
84 DO 83 K=1,L
R(1,K)=5
R(2,K)=R(7,K)
R(7,K)=0
R(3,K)=RJQ(1)
R(4,K)=R(8,K)
R(5,K)=100.
R(8,K)=0
83 R(6,K)=RJJ(K)
90 R(1,L+1)=100.
READX=-2
RETURN
END
C****** LOAD LAST ******
C****** FOR LISTS OF LETTERS, ETC. *******
SUBROUTINE ALPHA
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,ST(2800)
1,RJB,HGT,JJB,I' IS WRITTEN.)
RJF=RJE
RJE=65.
JA=5
JF=29
CALL NOTWRT
JF=27
JB=JB+11
51 CALL NOTWRT
IF(RJF.EQ.0)RETURN
JB=JB+16
52 JA=4
RJB=R+4.
JG=-2
C JG IS SWITCH TO DRAW WIGGLE
RJE=RJD+.8
CALL ITMSUB
RETURN
END
SUBROUTINE SLUR
IMPLICIT INTEGER(A-Q,T-Z)
REAL CENTR
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,ST(2800)
1,RJB,HGT,JJB,IPOS,JA,CENTR,J,JB,RW,K,RJQ(20),R,RA,L,RB,DISX,RX
1,JQ(20),WDS(200),IX,MEDIT,RJJ(20),STF(8)
EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJG,RJQ(5))
1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
1,(JK,JQ(9)),(JF,JQ(4)),(RJD,RJQ(2)),(RJE,RJQ(3))
DIMENSION SLURX(53),SLURY(53),RSEQ(26)
DATA RSEQ/70.0,64.0,59.0,53.9,49.0,44.1,40.0,35.8,32.0,28.2,
1 25.0,21.8,19.0,16.3,14.0,11.9,10.0,8.4,6.8,5.3
1 ,4.0,2.9,2.0,1.4,1.0,.07/
JJ=1
CC RJB=RJB*5.96-596.
80 RX=RJF*5.96-596.-RJB
R=CENTR
IF(JH.NE.0)GO TO 180
C FOR BRACKETS
DO 81 K=1,53
81 SLURX(K)=RX*(K-1)/52.+RJB
RA=-RJG*7.
R=R-RA
RJG=377.
RB=RJG
DO 82 K=1,26
SLURY(K)=RJG/RB*RA+R
SLURY(54-K)=SLURY(K)
82 RJG=RJG-RSEQ(K)
SLURY(27)=SLURY(26)
L=53
89 IF(JD.EQ.JE)GO TO 87
R=(RJE-RJD)*7.
CC RW=R/RX*180.0
RW=ATAN2(R,RX)
RA=SIN(RW)
RB=COS(RW)
RZ=SLURX(1)
RW=SLURY(1)
DO 84 K=1,L
SLURX(K)=SLURX(K)-RZ
84 SLURY(K)=SLURY(K)-RW
DO 83 K=1,L
R=SLURX(K)
SLURX(K)=RB*R-RA*SLURY(K)+RZ
83 SLURY(K)=RB*SLURY(K)+RA*R+RW
87 CALL LINES(SLURX(JJ),SLURY(JJ),3)
DO 88 K=JJ+1,L
88 CALL LINES(SLURX(K),SLURY(K),2)
RETURN
180 RW=R+RJG*7.
RX=RX+RJB
RA=(RJE-RJD)*7.
SLURX(1)=RJB
SLURY(1)=R
SLURX(2)=RJB
SLURY(2)=RW
SLURX(3)=RX
SLURY(3)=RW+RA
SLURX(4)=RX
SLURY(4)=R+RA
L=4
IF(JH.EQ.1)GO TO 87
IF(JH.EQ.2)L=3
IF(JH.EQ.3)JJ=2
GO TO 87
END
C 8, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
C FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
C******** JUGGLER ********
SUBROUTINE JUGGLE(X22)
IMPLICIT INTEGER(A-Z)
REAL DIS,RJB,PWDS,JJQ1,DISX,RN,RJC,RJB,RJQ,RJJ,RJF,RHT,A,B
COMMON /XRN/RN(4000)
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,ST(2800)
1,RJB,HGT,JJB,IPOS,JA,CENTR,J,JB,JY,K,RJQ(20),X,Y,L,CNT,DISX,JX
1,JQ(20),WDS(200),IX,MEDIT,RJJ(20)
ITEM=ITEM-1
JX=RN(MEDIT)+3
C WD CNT OF OLD ITEM
J=I-IX
C WD CNT OF NEW ITEM
JY=IX
Y=J-JX
C SPACE CHANGE
IF(Y)2751,172,751
751 CALL LOOP(I-1,MEDIT+JX,-1,Y,0,RN)
JY=IX+Y
GO TO 172
2751 J=MEDIT+JX+Y
CALL LOOP(MEDIT+JX+Y,IX+Y-1,1,0,-Y,RN)
172 J=RN(JY)+2
CALL LOOP(0,J,1,MEDIT,JY,RN)
I=IX+Y
DO 173 K=X22+1,ITEM+1
173 PWDS(K)=PWDS(K)+Y
1751 X=ITEM+1
JX=WDS(X22+1)-WDS(X22)
J=WDS(X+1)-WDS(X)
Y=J-JX
JX=WDS(X)+Y+1
IF(Y)2851,182,282
282 CALL LOOP(WDS(X+1)+2,WDS(X22),-1,Y,0,ST)
C JY=WDS(X)
GO TO 182
2851 CALL LOOP(WDS(X22+1)+Y+1,WDS(X)+Y+1,1,0,-Y,ST)
JX=WDS(X)+1
182 JY=WDS(X22)+1
CALL LOOP(1,J,1,JY,JX,ST)
DO 183 K=X22+1,X
183 WDS(K)=WDS(K)+Y
ST(2)=WDS(X)
X22=0
RETURN
END
SUBROUTINE LOOP(I,J,K,L,M,N)
DIMENSION N(1)
DO 1 NN=I,J,K
1 N(NN+L)=N(NN+M)
RETURN
END
SUBROUTINE PLTSRT
C SORTS DATA TO SHORTEN INVISIBLE VECTORS WHEN PLOTTING. LOAD AS LAST! SUBR.
C ********* LOAD THIS AFTER NOTWRT AND I(K)=PWDS(K)+Y
1751 X=ITEM+1
JX=WDS(X22+1)-WDS(X22)
J=WDS(X+1)-WDS(X)
Y=J-JX
JX=WDS(X)+Y+1
IF(Y)2851,182,282
282 CALL LOOP(WDS(X+1)+2,WDS(X22),-1,Y,0,ST)
C JY=WDS(X)
GO TO 182
2851 CALL LOOP(WDS(X22+1)+Y+1,WDS(X)+Y+1,1,0,-Y,ST)
JX=WDS(X)+1
182 JY=WDS(X22)+1
CALL LOOP(1,J,1,JY,JX,ST)
DO 183 K=X22+1,X
183 WDS(K)=WDS(K)+Y
ST(2)=WDS(X)
X22=0
RETURN
END
SUBROUTINE LOOP(I,J,K,L,M,N)
DIMENSION N(1)
DO 1 NN=I,J,K
1 N(NN+L)=N(NN+M)
RETURN
END
SUBROUTINE PLTSRT
C SORTS DATA TO SHORTEN INVISIBLE VECTORS WHEN PLOTTING. LOAD AS LAST! SUBR.
C ********* LOAD THIS AFTER NOTWRT AND ITMSUB !!!! *************
IMPLICIT INTEGER(S-Z)
COMMON /XRN/RN(4000)
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,P(2000),Y,K,V,W,A,L
DO 4 K=1,ITEM
L=PWDS(K)
4 P(K)=RN(L+2)+1000*RN(L+3)
Y=I
W=(I-1)*2
2 A=P(1)
L=1
DO 1 K=1,ITEM
IF(A.LE.P(K))GO TO 1
A=P(K)
L=K
1 CONTINUE
V=PWDS(L)
P(L)=10000
L=RN(V)+2
DO 3 K=0,L
3 RN(K+Y)=RN(K+V)
Y=Y+L+1
IF(Y.LT.W)GO TO 2
12 RETURN
END
SUBROUTINE BOX(A,B)
COMMON /SIZ/R,JCEN,KCEN
COMMON/SCM/V(78),LIST(200),ISCR,LCNT,RSTF,N(400)
DATA Q/596.0/
IF(B.EQ.999.)GO TO 4
K=(B-30.0)*R
X=(A*5.96-Q)*R
L=X-25.
1 CALL ALINE(L,K,L+50,K)
CALL RVECT(0,TMSUB !!!! *************
IMPLICIT INTEGER(S-Z)
COMMON /XRN/RN(4000)
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,P(2000),Y,K,V,W,A,L
DO 4 K=1,ITEM
L=PWDS(K)
4 P(K)=RN(L+2)+1000*RN(L+3)
Y=I
W=(I-1)*2
2 A=P(1)
L=1
DO 1 K=1,ITEM
IF(A.LE.P(K))GO TO 1
A=P(K)
L=K
1 CONTINUE
V=PWDS(L)
P(L)=10000
L=RN(V)+2
DO 3 K=0,L
3 RN(K+Y)=RN(K+V)
Y=Y+L+1
IF(Y.LT.W)GO TO 2
12 RETURN
END
SUBROUTINE BOX(A,B)
COMMON /SIZ/R,JCEN,KCEN
COMMON/SCM/V(78),LIST(200),ISCR,LCNT,RSTF,N(400)
DATA Q/596.0/
IF(B.EQ.999.)GO TO 4
K=(B-30.0)*R
X=(A*5.96-Q)*R
L=X-25.
1 CALL ALINE(L,K,L+50,K)
CALL RVECT(0,100)
CALL RVECT(-50,0)
CALL RVECT(0,-100)
L=L+25
2 CALL ALINE(L,K-25,L,K+125)
3 CALL DPYOUT(1)
RETURN
4 CALL DPYSET(3,N,100)
CALL DPYBRT(3)
L=A*R
CALL ALINE(L,-200,L,400)
CALL DPYOUT(3)
CALL SETPOG(1)
RETURN
END
SUBROUTINE LINES(A,B,L)
COMMON /SIZ/R,JCEN,KCEN
COMMON IPLT,RHT,DIS,I,PWDS(200),ITEM,JJ(2800)
1,RJB,HGT,JJB,IPOS,JA,CENTR,MQ,JB,JY,KQ,RJQ(20),X,Y,NQ,CNT,DISX,JX
1,JQ(20),WDS(200),IX,MEDIT,RJJ(20),STF(8)
EQUIVALENCE (ITOP,JJ(2799)),(IBOT,JJ(2800))
DATA BB/260.0/,CC/3.5/,DD/2.0/
C DELETED "R/0.8571/," FROM ABOVE LINE 2 APR.72 PER LCS LETTER
C 'R' SETS THE SIZE OF DPY IMAGE. CHNG100)
CALL RVECT(-50,0)
CALL RVECT(0,-100)
L=L+25
2 CALL ALINE(L,K-25,L,K+125)
3 CALL DPYOUT(1)
RETURN
4 CALL DPYSET(3,N,100)
CALL DPYBRT(3)
L=A*R
CALL ALINE(L,-200,L,400)
CALL DPYOUT(3)
CALL SETPOG(1)
RETURN
END
SUBROUTINE LINES(A,B,L)
COMMON /SIZ/R,JCEN,KCEN
COMMON IPLT,RHT,DIS,I,PWDS(200),ITEM,JJ(2800)
1,RJB,HGT,JJB,IPOS,JA,CENTR,MQ,JB,JY,KQ,RJQ(20),X,Y,NQ,CNT,DISX,JX
1,JQ(20),WDS(200),IX,MEDIT,RJJ(20),STF(8)
EQUIVALENCE (ITOP,JJ(2799)),(IBOT,JJ(2800))
DATA BB/260.0/,CC/3.5/,DD/2.0/
C DELETED "R/0.8571/," FROM ABOVE LINE 2 APR.72 PER LCS LETTER
C 'R' SETS THE SIZE OF DPY IMAGE. CHNG TO .7 FOR -20 TO 220 LINE SIZE.
22 GO TO 23
C CHANGE ABOVE TO 'JFCL' IN DDT TO USE NEXT ITEMS.
24 AA=CC-DD*ABS(A)/BB
C USE THIS IN DDT TO DISTORT ITEMS. CC MUST BE > DD
B=B*AA
23 IF(IPLT)GO TO 2
M=A*R
N=B*R
C THE NEXT 8 LINES ADDED 2 APR.72 PER LCS LETTER
IF(R.LE.0.8571)GO TO 3
C NEXT FOR DISPLAY MAGNIFICATION
M=M-JCEN
N=N-KCEN
IF(JA.NE.10)GO TO 3
C NEXT INSURES DISPLAY OF STAFF LINES
IF(M.GT.512)M=512
IF(M.LT.-512)M=-512
C THE ABOVE LINES ADDED 2 APR.72, LABEL 3 ADDED TO NEXT LINE
3 IF(IABS(M).GT.512.OR.IABS(N).GT.512)RETURN
K=B
IF(K.GT.ITOP)ITOP=B
IF(K.LT.IBOT)IBOT=B
1 IF(L.EQ.2)CALL AV TO .7 FOR -20 TO 220 LINE SIZE.
22 GO TO 23
C CHANGE ABOVE TO 'JFCL' IN DDT TO USE NEXT ITEMS.
24 AA=CC-DD*ABS(A)/BB
C USE THIS IN DDT TO DISTORT ITEMS. CC MUST BE > DD
B=B*AA
23 IF(IPLT)GO TO 2
M=A*R
N=B*R
C THE NEXT 8 LINES ADDED 2 APR.72 PER LCS LETTER
IF(R.LE.0.8571)GO TO 3
C NEXT FOR DISPLAY MAGNIFICATION
M=M-JCEN
N=N-KCEN
IF(JA.NE.10)GO TO 3
C NEXT INSURES DISPLAY OF STAFF LINES
IF(M.GT.512)M=512
IF(M.LT.-512)M=-512
C THE ABOVE LINES ADDED 2 APR.72, LABEL 3 ADDED TO NEXT LINE
3 IF(IABS(M).GT.512.OR.IABS(N).GT.512)RETURN
K=B
IF(K.GT.ITOP)ITOP=B
IF(K.LT.IBOT)IBOT=B
1 IF(L.EQ.2)CALL AVECT(M,N)
IF(L.EQ.3)CALL AIVECT(M,N)
RETURN
2 IF(IPLT.EQ.-2)RETURN
M=A*DIS
N=B*RHT
CALL PLOT(M,N,L)
RETURN
END
SUBROUTINE DRAW(I,J,N1,X,N1B,N2,N2B)
DIMENSION N1(1),N2(1)
DO 2 K=I,J
L=2
B=N2(K)*X+N2B
A=N1(K)*X+N1B
IF(N1(K).LT.60)GO TO 2
L=3
A=(N1(K)-100)*X+N1B
2 CALL LINES(A,B,L)
RETURN
END
C SETUP ALLOWS YOU TO SET UP RHYTHMS ON STAFF 4 FOR SPACING ALL OTHERS.
SUBROUTINE SETUP
IMPLICIT INTEGER(A-Q,S-Z)
REAL DIS,PWDS,DISX,A,B,STF,CENTR,POS
DIMENSION RPOS(2,40)
COMMON/SCM/V(78),LIST(200),ISCR,LCNT,RSTF,R(8,50)
COMMON /XRN/RN(4000)
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,ST(28ECT(M,N)
IF(L.EQ.3)CALL AIVECT(M,N)
RETURN
2 IF(IPLT.EQ.-2)RETURN
M=A*DIS
N=B*RHT
CALL PLOT(M,N,L)
RETURN
END
SUBROUTINE DRAW(I,J,N1,X,N1B,N2,N2B)
DIMENSION N1(1),N2(1)
DO 2 K=I,J
L=2
B=N2(K)*X+N2B
A=N1(K)*X+N1B
IF(N1(K).LT.60)GO TO 2
L=3
A=(N1(K)-100)*X+N1B
2 CALL LINES(A,B,L)
RETURN
END
C SETUP ALLOWS YOU TO SET UP RHYTHMS ON STAFF 4 FOR SPACING ALL OTHERS.
SUBROUTINE SETUP
IMPLICIT INTEGER(A-Q,S-Z)
REAL DIS,PWDS,DISX,A,B,STF,CENTR,POS
DIMENSION RPOS(2,40)
COMMON/SCM/V(78),LIST(200),ISCR,LCNT,RSTF,R(8,50)
COMMON /XRN/RN(4000)
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,ST(28ECT(M,N)
IF(L.EQ.3)CALL AIVECT(M,N)
RETURN
2 IF(IPLT.EQ.-2)RETURN
M=A*DIS
N=B*RHT
CALL PLOT(M,N,L)
RETURN
END
SUBROUTINE DRAW(I,J,N1,X,N1B,N2,N2B)
DIMENSION N1(1),N2(1)
DO 2 K=I,J
L=2
B=N2(K)*X+N2B
A=N1(K)*X+N1B
IF(N1(K).LT.60)GO TO 2
L=3
A=(N1(K)-100)*X+N1B
2 CALL LINES(A,B,L)
RETURN
END
C SETUP ALLOWS YOU TO SET UP RHYTHMS ON STAFF 4 FOR SPACING ALL OTHERS.
SUBROUTINE SETUP
IMPLICIT INTEGER(A-Q,S-Z)
REAL DIS,PWDS,DISX,A,B,STF,CENTR,POS
DIMENSION RPOS(2,40)
COMMON/SCM/V(78),LIST(200),ISCR,LCNT,RSTF,R(8,50)
COMMON /XRN/RN(4000)
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,ST(2800)
1,RJB,HGT,JJB,POS,JA,CENTR,J,JB,JY,K,RJQ(20),X,Y,L,CNT,DISX,JX
1,JQ(20),WDS(200),IX,MEDIT,RJJ(20),STF(8)
EQUIVALENCE (RJH,RJQ(6)),(RJI,RJQ(7)),(RPOS(1,1),RN(3921))
C ONLY DUPLE RHYTHMS MAY BE USED. SINGLE DOTS CAN BE USED.
X=0
DO 9534 K=1,ITEM
L=PWDS(K)
IF(RN(L+3).NE.4.)GO TO 9534
X=X+1
R(1,X)=RN(L+2)
IF(RN(L+5).NE.0)GO TO 31
RA=4.
GO TO 131
31 RB=RN(L+7)
IF(RN(L+6).LT.0)GO TO 231
RJH=AMOD(RB,10.0)
RA=1./2**RJH
GO TO 131
231 RA=2.
131 IF(RB.GT.9.)RA=RA+RA/2.
R(2,X)=RA
C RA IS RHYTHMIC VALUE OF NOTE.
9534 CONTINUE
C NEXT PUTS ITEMS IN PROPER ORDER IF THEY WEREN'T ALREADY
IF(X.EQ.0)RETURN
K=0
X=X+1
R(1,X)=200.
331 Y=1
531 RA=R(1,Y)
DO 431 L=1,X
IF(RA.LE.R(1,L))GO TO 431
Y=L
GO TO 531
431 CONTINUE
K=K+1
RPOS(1,K)=RA
RPOS(2,K)=R(2,Y)
R(1,Y)=1000.
IF(K.LE.X)GO TO 331
RPOS(1,X)=200.
RPOS(2,X)=0
RETURN
END
C****** FOR 'HOMING' OF BEAMS AND CHORD NOTES ***********
SUBROUTINE HOMER
IMPLICIT INTEGER(A-Q,S-Z)
REAL DIS,PWDS,DISX,A,B
COMMON /XRN/RN(4000)
COMMON PLT,RHT,DIS,I,PWDS(200),ITEM,ST(2800)
1,RJB,HGT,JJB,POS,JA,CENTR,RA,JB,RB,K,RJQ(20),X,Y,L,CNT,DISX,RC
1,JQ(20),WDS(200),IX,MEDIT,RJJ(20),STF(7)
EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJE,RJQ(3))
1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
1,(JK,JQ(9)),(JF,JQ(4)),(RJG,RJQ(5)),(RJI,RJQ(7))
IF(JA-9)1,9,190
C ADJUSTS STEMS WHEN BEAMS ARE USED.
190 DO 191 K=1,ITEM
L=PWDS(K)
IF(RN(L+1).NE.9.)GO TO 191
RG=RN(L+7)
IF(RN(L).EQ.8..OR.RG.LT.10.)GO TO 191
C FINDS BEAMS.
A=RN(L+2)
B=RN(L+6)
C POS 1 AND 2
DISX=B-A
C DISTANCE IN REAL STEPS
RB=AMOD(RN(L+5),100.0)
C NOTE 2
RF=AMOD(RN(L+4),100.0)
RD=RB-RF
C HEIGHT
RJC=RN(L+3)
X=RG/10.
C STEM DIRECT.
DO 192 N=1,ITEM
L=PWDS(N)
IF(RN(L+1).NE.1..OR.RN(L+3).NE.RJC)GO TO 192
RC=RN(L+2)
IF(RC.LT.A.OR.RC.GT.B)GO TO 192
C WHAT'S LEFT IS IN BEAM AREA IF STEM DIR. IS OK.
IF(X.NE.IFIX(RN(L+5)/10.))GO TO 192
RC=RC-A
193 RE=AMOD(RN(L+4),100.0)
RC=RD*RC/DISX+RF
RG=RN(L+7)
RN(L+7)=RG-AMOD(RG,10.0)+AMOD(RG,1.0)
C DELETES TAILS WITHOUT REMOVING DOTS OR SPACING OF DOTS.
C FRACTIONAL NOTE #
195 RA=RC-RE
IF(X.EQ.2)RA=-RA
196 RN(L+8)=RA
C FRACTIONAL NOTE # - FIRST NOTE OF GROUP + THIS NOTE # ALL *7.
192 CONTINUE
191 CONTINUE
RETURN
1 IF(ABS(RJF).LT.2)RETURN
C NO 'HOMING' NEEDED
RB=ABS(RJF)
GO TO 10
9 X=RJG/10.
C X IS STEM DIRECTION
RA=RJI
10 DO 361 K=1,ITEM
L=PWDS(K)
Y=RN(L+5)
IF(RN(L+1).NE.1.OR.RN(L+3).
C WHAT'S LEFT IS IN BEAM AREA IF STEM DIR. IS OK.
IF(X.NE.IFIX(RN(L+5)/10.))GO TO 192
RC=RC-A
193 RE=AMOD(RN(L+4),100.0)
RC=RD*RC/DISX+RF
RG=RN(L+7)
RN(L+7)=RG-AMOD(RG,10.0)+AMOD(RG,1.0)
C DELETES TAILS WITHOUT REMOVING DOTS OR SPACING OF DOTS.
C FRACTIONAL NOTE #
195 RA=RC-RE
IF(X.EQ.2)RA=-RA
196 RN(L+8)=RA
C FRACTIONAL NOTE # - FIRST NOTE OF GROUP + THIS NOTE # ALL *7.
192 CONTINUE
191 CONTINUE
RETURN
1 IF(ABS(RJF).LT.2)RETURN
C NO 'HOMING' NEEDED
RB=ABS(RJF)
GO TO 10
9 X=RJG/10.
C X IS STEM DIRECTION
RA=RJI
10 DO 361 K=1,ITEM
L=PWDS(K)
Y=RN(L+5)
IF(RN(L+1).NE.1.OR.RN(L+3).(8),SHY(8)
1,FLX(7),FLY(7),NATX(6)
1, NATY(6),EX(6),EY(6),QX(10),QY(10),FILY(14),TAILX(6),TAILY(6)
COMMON /NU/NUMQ(42),NUMX(311),NUMY(311)
COMMON /NX/FERMX(15),FERMY(15)
DATA DAX/30,32,34,32,30,31,32,33,31,31/,
1 DAY/56,58,56,54,56,56,57,56,55,56/
DATA NX/100,2,6,10,14,16,14,10,6,2,0/,NY/0,5,7,7,5,0,-5,-7,-7,-5
1,0/, SHX/-4,-18,-14,-14,-18,-4,-8,-8/
1, SHY/-4,-8,-14,13,4,8,15,-12/
1, FLX/-14,-11,-8,-6,-7,-14,-14/,FLY/3,7,7,3,-1,-9,19/
1, NATX/-6,-6,-14,-14,-14,-6/,NATY/-16,7,4,16,-7,-4/
1,EX/0,0,2,6,12,6/,EY/9,7,5,5,8,-17/, QX/6,2,2,4,10,0,5,8,8,2/
1,QY/16,12,10,8,7,-7,-7,-11,-15,-17/
1, FILY/2,-4,5,-5,6,-6,6,-6,6,-6,5,-5,4,-2/
1, TAILX/10,13,12,13,10,0/,TAILY/10,20,25,20,9,-1/
1,NUMQ/1,11,15,23,33,38,47,57,62,79, 89,95,108,117,125,132,138
1,150,157,160,167,173,177,183,1,188,196,208,217,230,235,242
1,246,252,257,262, 267,278,281,289,294,303/
DATA NUMX/10,103,6,6,3,-4,-7,-7,-4,3
1,14,97,1,1 ,22,95,-1,3,7,7,-7,7, 32,93,7,-1,3,7,7,3,-3,-7, 37
1,107,-7,2,2, 46,93,4,7,7,2,-7,-7,7, 56,104,-7,-7,-3,4,7,7,3,-4,
1 61,93,-7,7,-7, 78,103,7,7,4,-4,-7,-7,-3,3,6,6,2,-2,-6,-6,-3, 88
1,96,7,7,4,-4,-7,-7,-3,4, 94,94,0,6,103,-4, 107,94,-6,2,6,6,2,-6
1,103,6,6,3,-6, 116,106,3,-3,-6,-6,-3,3,6, 124,94,-6,3,6,6,3,-6
1,131,106,-6,-6,6,103,-6, 137,94,-6,6,103,-6, 149,101,1,6,6,3,-3
1,-6,-6,-3,3,6, 156,94,-6,106,6,106,-6, 159,100,0, 166,94,-6
1,-3,3,6,6, 172,94,-6,106,-6,6, 176,106,-6,-6, 182,94,-6,0,6,6
1,187,94,-6,6,6, 195,94,-6,3,6,6,3,-6, 207,103,6,6,3,-3,-6,-6,-3
1,3,101,7, 216,94,-6,3,6,6,3,-6,6, 229,94,-3,3,6,6,3,-3,-6
1,-6,-3,3,6, 234,94,7,100,0, 241,94,-6,-3,3,6,6, 245,94,0,6
1,251,94,-4,0,4,6, 256,94,6,94,6, 261,94,0,94,6, 266,94,6
1,-6,6, 277,99,-1,0,0,1,1,-1,101,1,-2, 280,94,6, 288,99,-1,0,0
1,1,1,-1, 293,94,6,106,-6, 302,103,0,-2,-3,-3,-2,0,3, 311,97,0
1,2,3,3,2,0,-3/
C 1-10=NUMS 0-9, 11-36=ALPHA, 37-42=SIGNS
DATA NUMY/0,-7,-2,10,15,15,10,-2,-7,-7, 0
1,11,15,-7, 0, 11,15,15,11,5,-7,-7, 0, 15,15,7,7,3,-2,-7,-7,-3, 0
1,-2,-2,15,-7, 0, -7,-3,0,4,6,4,15,15, 0, 15,0,-3,-7,-7,-3,0,3,3
1, 0,11,15,15,-7, 0, 4,0,-3,-7,-7,-3,0,4,4,8,12,15,15,12,8,4, 0
1,-7,8,11,15,15,11,8,5,5, 'A', -7,15,-7,0,0, 0,-7,15,15,12,7,4,4
1 ,3,1,-4,-7,-7, 0,-4,-7,-7,-4,11,15,15,10, 116,-7,15,15,11,-3
1,-7,-7, 0,-7,-7,15,15,5,5, 0,-7,15,15,5,5, 0,-4,-2,-2,-4,-7,-7
1,-4,11,15,15,10, 0,-7,15,15,-7,5,5, 0,-7,15, 0,-2,-4,-7,-7,-4,15
1,0,-7,15,15,5,-7
1,0,-7,-7,15, 0,-7,15,4,15,-7, 0,-7,15,-7,15, 0,-7,15,15,12,7,4
1,4 ,0,-7,-2,10,15,15,10,-2,-7,-7,1,-8,216,-7,15,15,12,7,4,4,-7
1,0,-4,-7,-7,-4,1,4,4,7,11,15,15,10, 0,15,15,15,-7
1,0,15,-4,-7,-7,-4,15, 0,15,-7,15, 0,15,-7,5,-7,15
1,0,15,-7,-7,15, 0,15,3,-7,15
1,0,15,15,-7,-7, 277,-2,-5,-2,-5,-2,-5,-2,-5,-8,-12, 280,4,4
1,288,-2,-5,-2,-5,-2,-5,-2, 293,8,8,1,1, 302,15,13,9,7,0,-1,-5
1,-7, 311,15,13,9,7,0,-1,-5,-7/
DATA FERMX/0,1,3,7,11,15,17,18,16,13,10,8,4,2,0/,FERMY/0,6,8,10
1 ,10,8,6,0,6,8,9,9,8,6,0/
END
SUBROUTINE SCMSS
DATA ISEMI/';'/
COMMON/SCM/V(78),JLIST(200),I,LCNT,STAFF,R(8,50)
DIMENSION RLIST(200)
COMMON /SCX/SIG(12),RHY(4),JALPHA(7,15,12,7,4
1,4 ,0,-7,-2,10,15,15,10,-2,-7,-7,1,-8,216,-7,15,15,12,7,4,4,-7
1,0,-4,-7,-7,-4,1,4,4,7,11,15,15,10, 0,15,15,15,-7
1,0,15,-4,-7,-7,-4,15, 0,15,-7,15, 0,15,-7,5,-7,15
1,0,15,-7,-7,15, 0,15,3,-7,15
1,0,15,15,-7,-7, 277,-2,-5,-2,-5,-2,-5,-2,-5,-8,-12, 280,4,4
1,288,-2,-5,-2,-5,-2,-5,-2, 293,8,8,1,1, 302,15,13,9,7,0,-1,-5
1,-7, 311,15,13,9,7,0,-1,-5,-7/
DATA FERMX/0,1,3,7,11,15,17,18,16,13,10,8,4,2,0/,FERMY/0,6,8,10
1 ,10,8,6,0,6,8,9,9,8,6,0/
END
SUBROUTINE SCMSS
DATA ISEMI/';'/
COMMON/SCM/V(78),JLIST(200),I,LCNT,STAFF,R(8,50)
DIMENSION RLIST(200)
COMMON /SCX/SIG(12),RHY(4),JALPHA(7),JX,JXX,JZ,IRHY,JD,KA,KB,IZ
COMMON /SC/J,L,MK
1 ,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG,IXX,ISEMI,IQT
1 ,INP(72),VX(50),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,MODE,IBLA
EQUIVALENCE (VX1,VX(1)),(INP1,INP(1)),(IPP,ISCA(2)),(IEN,ISCA(4)),
1(ISS,ISCA(9)),(ITT,ISCA(11)),(IE,ISCA(5)),(ID,ISCA(3))
1,(IF,ISCA(6)),(IAA,ISCA(10)),(VX2,VX(2)),(VX3,VX(3))
1,(VX4,VX(4)),(VX5,VX(5)),(IDOT,IDAT(11)),(JLIST,RLIST)
DATA IBLA/' '/,KSLA/'/'/,IXX/'X'/,SIG/3.,111.,10.,104.,5.,109.
1,12.,102.,1007.,107.,1002.,112./,LCNT/1/
1 ,ISCA/'C','P','D','N','E','F','O','G','S','A','T','B'/
1 ,IDAT/'0','1','2','3','4','5','6','7','8','9','.'/
1,RHY/.5,.25,.125,.0625/,JALPHA/',','-','.','=','(',')',' '/
8012 IF(NTX.EQ.0)GO TO 8001
NTX=0
TYPE 8008
MODE=5
CC JXX=JX
GO TO 2308
8008 FORMAT(' TYPE RHYTHM'/)
C****** MODES: 1=NOTES, 2=KEY SIG, 3=LETTERS, 4=DBL STOPS, 5=RHYTHM(COMES AFTER NOTES)
CC8001 JXX=0
8001 LCNTZ=LCNT
CC I=1
INZ=I
RHL=0
C MODES: 1=NOTES, 2=KEY SIG, 4=BEAMS, 5=RHYTHM
C '9'=99 FOR BACKUP
MODE=R(1,1)-13.
GO TO (8004,8004,30,8004,20) MODE
8002 FORMAT(' ADD BEAMS?'/)
8022 FORMAT(' ADD SLURS?'/)
20 IF(IBEAM)GO TO 8019
C RETURNS HERE FOR NO GOOD REASON AT THIS TIME!!!!
TYPE 8002
2001 IBEAM=0
ACCEPT 2114,N
CC IF(N.EQ.'N')GO TO 8018
IF(N.EQ.'N')GO TO 2000
IF(N.EQ.'9')GO TO 8004
IBEAM=-1
MODE=4
GO TO 8004
2000 IBEAM=-1
IF(JXX)GO TO 8014
C JUMP IF BEAMS JUST FINISHED.
CJD=JXX
JXX=-JXX
2002 TYPE 8022
JX=IZ
CC IBEAM=-1
GO TO 2001
8019 IBEAM=0
CC8018 JXX=0
8014 RHX=0
8000 IF(IBEAM)GO TO 8006
R(8,50)=-1.
8006 R(1,JX+1)=100
RETURN
8016 IF(INP(3).EQ.'9')GO TO 8017
JXX=1
R(1,1)=0
R(2,1)=0
GO TO 8006
C TYPE '999' TO ESCAPE FROM 'SCORE' MODE.
8017 IF(MODE.NE.2)GO TO 8001
1222 IF(JXX.EQ.0)GO TO 8001
DO 2222 K=1,JXX
2222 R(1,K)=99.
NTX=0
JXX=0
LCNT=LCNTZ
CC I=INZ
GO TO 8006
C '99' IN RHYTHM WILL ERASE NOTE INPUT.
8003 CONTINUE
C TYPE '0 E' TO END SCORE INPUT.
GO TO 8001
C FOR BACKUP
8007 NTX=-1
JX=JXX
GO TO 8006
8010 RHX=-1.
CC IF(JX.NE.JXX)GO TO 8015
CC JXX=JD
CC JX=JD
JX=IZ
IF(IBEAM)GO TO 8014
CC IF(IBEAM)GO TO 8018
GO TO 8006
C JD IS FOR DOTTED RHYTHMS
8015 TYPE 8011
LCNT=LCNTX
CC I=INX
GO TO 2308
8011 FORMAT(' NUMBERS OF ITEMS ARE UNEQUAL. TYPE OVER.'/)
C NOTES, THEN RHYTHM, MUST ALWAYS BE DONE TOGETHER!!
8004 TYPE 8005
8005 FORMAT(' TYPE----'/)
CC2308 IZ=I
2308 I=1
ACCEPT 2114,INP
IF(INP(1).EQ.IBLA) GO TO 8012
IF(INP(1).EQ.'9'.AND.INP(2).EQ.'9')GO TO 8016
C TYPE '99' TO BACK-UP
LCNTX=LCNT
RETRO=-1.
PARENS=0
JZ=1
IAMP=0
C IAMP IS 'BLANK LINE'FLAG ON PP1-3.
KL=0
KN=IBLA
RA=0
2408 MLX=1
L=-1
DO 2999 K=1,72
IF(INP(K).EQ.IBLA)GO TO 2999
L=0
IF(INP(K).NE.'*')GO TO 2999
C READS 72 CHARS. INCLUDING *.
INP(K+1)=ISEMI
GO TO 1773
C --- X/Y/Z* --- WITH NO SEMICOLON WORKS FOR THIS PROG. ONLY!
2999 CONTINUE
1299 IF(JZ.NE.0)GO TO 1773
7773 TYPE 8005
ACCEPT 2114,INP
IF(INP1.EQ.IBLA)GO TO 7773
JA=-1
JZ=0
GO TO 2408
C 'LISTS' MUST END WITH *
1773 JZ=0
DBST=1.
17731 ML=MLX
DO 236 JDD=ML,72
JD=JDD
N=I016
C TYPE '99' TO BACK-UP
LCNTX=LCNT
RETRO=-1.
PARENS=0
JZ=1
IAMP=0
C IAMP IS 'BLANK LINE'FLAG ON PP1-3.
KL=0
KN=IBLA
RA=0
2408 MLX=1
L=-1
DO 2999 K=1,72
IF(INP(K).EQ.IBLA)GO TO 2999
L=0
IF(INP(K).NE.'*')GO TO 2999
C READS 72 CHARS. INCLUDING *.
INP(K+1)=ISEMI
GO TO 1773
C --- X/Y/Z* --- WITH NO SEMICOLON WORKS FOR THIS PROG. ONLY!
2999 CONTINUE
1299 IF(JZ.NE.0)GO TO 1773
7773 TYPE 8005
ACCEPT 2114,INP
IF(INP1.EQ.IBLA)GO TO 7773
JA=-1
JZ=0
GO TO 2408
C 'LISTS' MUST END WITH *
1773 JZ=0
DBST=1.
17731 ML=MLX
DO 236 JDD=ML,72
JD=JDD
N=IRENS.EQ.0)GO TO 236
3362 PARENS=0
MOT=I-LMOT
JLIST(LCNT+1)=MOT
LCNT=LCNT+1
DO 2140 JG=1,MOT
2140 RLIST(LCNT+JG)=V(LMOT-1+JG)
LCNT=LCNT+MOT+1
IF(IAMP)GO TO 3013
GO TO 236
C ))))))))))) LAST ) CAN'T APPEAR AT END OF LINE!!
C IF LAST ITEM IS IN MOTIVE, * CLOSES THE PARENTHESES.
C @@@@@@@@@@@@ /@Z/DS3/ ETC.
2361 IF(N.NE.'@')GO TO 5361
DO 113 L=1,72
K=JD+L
C K IS USED AT 240!!!
JG=INP(K)
IF(JG.NE.'-')GO TO 7113
RETRO=0
INP(K)=IBLA
GO TO 113
7113 IF(JG.NE.IBLA)GO TO 4113
113 CONTINUE
4113 DO 6361 L=1,LCNT
IF(JG.NE.JLIST(L))GO TO 6361
VX1=0
DO 40 M=JD+2,72
JG=INP(M)
IF(JG.EQ.IBLA)GO TO 40
IF(JG.EQ.KSLA.OR.JG.EQ.ISEMI.OR.JG.EQ.'*')GO TO 140
ML=M
GO TO 240
40 CONTINUE
240 JC=JA
JA=-1
INP(K)=IBLA
CALL SCANR
JA=JC
140 JC=1
KN=L+2
M=KN+JLIST(L+1)-1
IF(RETRO)GO TO 940
KN=M
M=L+2
JC=-1
RETRO=-1.
940 Z=RLIST(KN)
IF(VX1.EQ.0)GO TO 540
C " @Q N " WHERE N= 1/2 STEPS IN 'NOTES' OR MULT FACTOR IN OTHERS.
IF(MODE.EQ.1)GO TO 440
C MODE 1 IS NOTES, 5 IS RHY.
V(I)=Z*VX1
GO TO 7361
440 IF(Z.EQ.85.)GO TO 540
V(I)=Z+VX1
GO TO 7361
540 V(I)=Z
7361 I=I+1
KN=KN+JC
IF(KN.LE.M)GO TO 940
RB=V(I-1)
ICT=-1
DO 8361 L=JD,72
JG=INP(L)
INP(L)=IBLA
IF(JG.EQ.KSLA)GO T TO 40
IF(JG.EQ.KSLA.OR.JG.EQ.ISEMI.OR.JG.EQ.'*')GO TO 140
ML=M
GO TO 240
40 CONTINUE
240 JC=JA
JA=-1
INP(K)=IBLA
CALL SCANR
JA=JC
140 JC=1
KN=L+2
M=KN+JLIST(L+1)-1
IF(RETRO)GO TO 940
KN=M
M=L+2
JC=-1
RETRO=-1.
940 Z=RLIST(KN)
IF(VX1.EQ.0)GO TO 540
C " @Q N " WHERE N= 1/2 STEPS IN 'NOTES' OR MULT FACTOR IN OTHERS.
IF(MODE.EQ.1)GO TO 440
C MODE 1 IS NOTES, 5 IS RHY.
V(I)=Z*VX1
GO TO 7361
440 IF(Z.EQ.85.)GO TO 540
V(I)=Z+VX1
GO TO 7361
540 V(I)=Z
7361 I=I+1
KN=KN+JC
IF(KN.LE.M)GO TO 940
RB=V(I-1)
ICT=-1
DO 8361 L=JD,72
JG=INP(L)
INP(L)=IBLA
IF(JG.EQ.KSLA)GO TSEMI
236 CONTINUE
130 FORMAT(' TYPE POS, NOTE #, SIZE(100S)'/)
2114 FORMAT(72A1)
131 FORMAT(4F)
CC30 IF(JXX.NE.0)GO TO 8001
30 TYPE 130
ACCEPT 131,RA,RB,RC
IF(RA.EQ.99.)GO TO 8001
IF(RC.EQ.0)RC=100.
TYPE 8005
ACCEPT 2114,INP
DO 31 K=72,1,-1
31 IF(INP(K).NE.IBLA)GO TO 33
33 IF(INP(K).EQ.'*')K=K-1
JX=(K-1)/12+1
L=1
KB=6
DO 364 KA=1,JX
R(1,KA)=50.
R(2,KA)=RA
C NEXT IS A MAGIC NUMBER FOR SPACING LETTERS.
Y=39.6
26 RA=RA+Y*RC/100.
R(3,KA)=STAFF
R(4,KA)=RB
R(5,KA)=RC
DO 364 JE=6,8
Y=0
DO 363 JD=1,4
361 JC=INP(L)
JB=0
DO 362 J=1,7
362 IF(JC.EQ.JALPHA(J))JB=J
IF(JB.EQ.0)GO TO 38
N=35+JB
GO TO 39
38 N=10-('A'-INP(L))/536870912
IF(N.LT.10)N=N+7
39 L=L+1
IF(N.EQ.42)N=99
C BLANK=99
X=N
IF(JD.EQ.2)X=X*100.
IF(JD.EQ.4)X=X/100.
IF(JD.EQ.1)X=X*10000.
363 Y=Y+X
364 R(JE,KA)=Y
RHL=0
GO TO 8014
C PACKS 4 CHARS/WD, 3 WDS/ITEM. ORDER=[, - . = ( )] 000000.00
5016 IF(IAMP.GE.0)GO TO 1299
IF(PARENS)GO TO 3362
C PARENS ARE STILL OPEN?
GO TO 3013
103 K=INP(ML)
IF(K.EQ.ISEMI)GO TO 1014
JA=-1
IF(MODE.NE.5)JA=0
IF(K.NE.IBLA) GO TO 1899
ML=ML+1
GO TO 103
1899 CALL SCANR
3 IF(VX1.EQ.-99.)GO TO 4022
IF(MODE.NE.5)GO TO 17
2017 IF(VX1.EQ.10000.)GO TO 17
VX1=4./VX1
IF(JJ.NE.1)GO TO 2014
V(I)=VX1
GO TO 114
2014 DO 9006 L=2,JJ
IF(VX(L).EQ.0)GO TO 17
9006 VX1=4./VX(L)+VX1
JJ=1
17 V(I)=VX1
IF(JJ.EQ.1)GO TO 114
L=VX(JJ)-1
X=V(I)
NL=I+1
I=L+I
DO 1017 K=NL,I
1017 V(K)=X
C ADDS UP TOTAL OF NOTES IN SEQ.
GO TO 114
1014 V(I)=RB
114 RB=V(I)
I=I+1
GO TO 5016
4022 JC=VX2+.3
JD=VX3-.5
IF(JJ.EQ.2)JD=1
C JC=HOW MANY TIMES, JD=HOW MANY NOTES
DO 1005 K=1,JD
NL=I+JC-1
DO 2005 L=I,NL
2005 V(L)=V(L-JC)
1005 I=I+JC
RB=V(NL)
C RB SAVES DATA FOR SLASH REPEAT FEATURE.
GO TO 5016
3013 IF(MODE.GT.2.AND.I-1.NE.IRHY)GO TO 8015
C WRONG NUMBER OF ITEMS
V(I)=-99.
GO TO (4333,5333,3,2333,1333),MODE
4333 CALL NOTES
GO TO 8007
1333 CALL RHYTH
GO TO 8010
5333 CALL KSIG
GO TO 8000
2333 CALL BEAMS
IF(JXX)GO TO 2002
GO TO 8010
END
SUBROUTINE BEAMS
COMMON/SCM/V(78),LIST(200),I,LCNT,STAFF,R(8,50)
COMMON /SCX/SIG(12),RHY(4),JALPHA(7),JX,JXX,JZ,IRHY,JD,KA,KB,IZ
COMMON /SC/J,L,MK
1 ,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG,IXX,ISEMI,IQT
1 ,INP(72),VX(50),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,MODE,IBLA
RX=0
RSLUR=0
IF(JXX.GT.0)GO TO 201
RX=-1.
RSLUR=1.5
C NEG=SLURS BELOW, POS=SLURS ABOVE
201 KN=0
K=-1
K=1
2 IF(V(K).NE.0)GO TO 22
X=R(2,K+KN)
222 IF(X.NE.R(2,K+KN+1))GO TO 1
KN=KN+1
GO TO 222
C SKIPS DBL STOP NOTES WITHOUT BEAMS.
22 X=V(K)
C FOR STEM DIRECTION.
IF(X.EQ.9.)X=99.
C CATCHES TYPO ERROR ON 99.
IZ=IZ+1
R(1,IZ)=9.+RX
C IF SLURS, RX=-1
JJ=K+KN
R(2,IZ)=R(2,JJ)+RSLUR
C ABOVE IS POS.1
R(7,IZ)=X
C=R(4,JJ)
D=C
C C=NOTE 1.
UMAX=C
DMAX=C
C UP MAX. NOTE #, DOWN MAX. NOTE #.
IF(RX.EQ.0)GO TO 103
C JUMP IF NOT IN SLUR MODE
RB=2.
IF(X)RB=-2.
RA=X
X=20.
IF(RA)X=10.
CC IF(RA.EQ.0)RA=RB
C DIP IS SET BY PARAM 7. (STEM DIR. IS AUTOMATIC)
R(4,IZ)=C+RB
C SETS BEGINNING LEVEL OF SLUR
103 DO 3 M=K,I
CC N=M
IF(V(M).EQ.99.)SL2=R(4,M+KN)+RB
334 N=M+KN
CC334 N=N+KN
Y=R(5,N)
B=R(4,N)
33 IF(X.LT.20.)GO TO 5
C JUMP IF STEM DOWN
IF(B.LT.C)C=B+1
IF(Y.LT.20..AND.Y.GE.10.)R(5,N)=Y+10.
GO TO 55
5 IF(Y.GE.20.)R(5,N)=Y-10.
C STEM UP
IF(B.GT.C)C=B-1
CC55 JC=N+KN
55 JC=M+KN
IF(R(2,JC).NE.R(2,JC+1).OR.R(1,JC).NE.1.)GO TO 333
KN=KN+1
GO TO 334
C SKIPS OVER DBLSTOP NOTES WITH BEAMS.
333 IF(V(M).EQ.99.)GO TO 4
IF(B.GE.C)UMAX=B
IF(B.LE.C)DMAX=B
3 CONTINUE
C LOOKS FOR LOWER AND HIGHER NOTES THAN NOTE 1.
C SETS LEVEL FOR END OF SLUR
CC4 IF(RX)SL2=R(4,M+KN)+RB
C SETS HEIGHT OF SLUR END
CC441 IF(R(2,M+KN+1).NE.R(2,M+KN))GO TO 41
C IS LAST ITEM UNDER BEAM DBLSTOP?
CC KN=KN+1
CC GO TO 441
4 B=R(4,N)
E=C
G=E
IF((B.GT.UMAX.AND.UMAX.GT.D).OR.(B.LT.DMAX.AND.DMAX.LT.D))GOTO44
IF(C.EQ.D)E=R(4,N)
CC IF(RX.EQ.0)GO TO 444
GO TO 444
44 E=B
CC** RA=RB
G=(C+D)/2
IF(B-C.EQ.C-D)G=D
444 R(3,IZ)=STAFF
IF(RX)GO TO 446
R(4,IZ)=G
GO TO 445
CC446 E=R(4,M+K)+RB
446 E=SL2
C SLUR LANDS ON INITIAL NOTE OF CHORD
R(7,IZ)=RA
C RA IS DIP IN SLUR
445 R(5,IZ)=E
C MAKES HORIZONTAL BEAMS IF PATTERN IS UP-DOWN.
R(6,IZ)=R(2,N)+RSLUR
CND OF SLUR
CC4 IF(RX)SL2=R(4,M+KN)+RB
C SETS HEIGHT OF SLUR END
CC441 IF(R(2,M+KN+1).NE.R(2,M+KN))GO TO 41
C IS LAST ITEM UNDER BEAM DBLSTOP?
CC KN=KN+1
CC GO TO 441
4 B=R(4,N)
E=C
G=E
IF((B.GT.UMAX.AND.UMAX.GT.D).OR.(B.LT.DMAX.AND.DMAX.LT.D))GOTO44
IF(C.EQ.D)E=R(4,N)
CC IF(RX.EQ.0)GO TO 444
GO TO 444
44 E=B
CC** RA=RB
G=(C+D)/2
IF(B-C.EQ.C-D)G=D
444 R(3,IZ)=STAFF
IF(RX)GO TO 446
R(4,IZ)=G
GO TO 445
CC446 E=R(4,M+K)+RB
446 E=SL2
C SLUR LANDS ON INITIAL NOTE OF CHORD
R(7,IZ)=RA
C RA IS DIP IN SLUR
445 R(5,IZ)=E
C MAKES HORIZONTAL BEAMS IF PATTERN IS UP-DOWN.
R(6,IZ)=R(2,N)+RSLUR
CND OF SLUR
CC4 IF(RX)SL2=R(4,M+KN)+RB
C SETS HEIGHT OF SLUR END
CC441 IF(R(2,M+KN+1).NE.R(2,M+KN))GO TO 41
C IS LAST ITEM UNDER BEAM DBLSTOP?
CC KN=KN+1
CC GO TO 441
4 B=R(4,N)
E=C
G=E
IF((B.GT.UMAX.AND.UMAX.GT.D).OR.(B.LT.DMAX.AND.DMAX.LT.D))GOTO44
IF(C.EQ.D)E=R(4,N)
CC IF(RX.EQ.0)GO TO 444
GO TO 444
44 E=B
CC** RA=RB
G=(C+D)/2
IF(B-C.EQ.C-D)G=D
444 R(3,IZ)=STAFF
IF(RX)GO TO 446
R(4,IZ)=G
GO TO 445
CC446 E=R(4,M+K)+RB
446 E=SL2
C SLUR LANDS ON INITIAL NOTE OF CHORD
R(7,IZ)=RA
C RA IS DIP IN SLUR
445 R(5,IZ)=E
C MAKES HORIZONTAL BEAMS IF PATTERN IS UP-DOWN.
R(6,IZ)=R(2,N)+RSLUR
CCC X=V(IZ)
X=V(1)
153 L=X/100.
IF(L.EQ.1.OR.X.EQ.6.)GO TO 253
W=-3.
Y=4.
Z=11.
C SHARPS
GO TO 353
253 W=3.
Y=-4.
Z=7.
C FLATS
353 JX=1
DO 453 K=1,12
453 IF(X.EQ.SIG(K))JX=(K+3)/2
N=1
CC RA=10.5
RA=R(2,1)
RC=1.
IF(W)RC=2.
DO 553 K=1,JX
R(1,K)=6.
R(2,K)=RA
RA=RA+2.2
R(5,K)=RC
R(3,K)=STAFF
RD=Z
R(4,K)=Z
Z=RD+W
IF(N)Z=RD+Y
553 N=-N
L=CLEF
Z=10.
CC L=-L
CC IF(L.NE.1)GO TO 753
IF(CLEF.LT.-2.)Z=11.
IF(CLEF.NE.-1.)GO TO 753
653 DO 6531 K=1,JX
6531 IF(R(4,K).GT.12.)R(4,K)=R(4,K)-7.
RETURN
753 Y=CLEF+4.
IF(CLEF.EQ.-4)Y=-1.
DO 7531 K=1,JX
X=R(4,K)-Y
IF(X.GT.Z)X=X-7.
7531 R(4,K)=X
RETURN
END